diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,6 +0,0 @@ -* 0.1.1.0 Bug-fix release - - - fixed: automatically create output directory, if it does not exist - - fixed: wrong flags given in help message for starting interactive mode - -* 0.1.0.0 First public release diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,127 +0,0 @@ -====================================================================== -README for the tamarin-prover for security protocol verification -====================================================================== - -Author: Simon Meier - -Creation Date: 8/02/2012 - - -1. Introduction -=============== - - The tool is written in Haskell and provides two usage modes as described - below. - - - NOTE TO REVIEWERS: - to reproduce our results from the paper install the tool and run - - make case-studies - - in the root directory of this source distribution. This will create - a directory './case-studies' with the analyzed files and their proofs and - attacks. - - - -2. Installation instructions -============================ - -2.1 Requirements ----------------- - - The tool was tested on Linux and Mac OsX. It relies on - - - maude version 2.6 for AC unification - - download and install "Full Maude 2.6" from http://maude.cs.uiuc.edu/download/ - - - the 'dot' tool from GraphViz for rendering proof states as graphs - - download and install from http://www.graphviz.org/ - (most Linux distributions have a corresponding package) - - - GHC 7.0.4 and cabal-install - - included in the Haskell Platform 2011.2.0.1 - available from http://hackage.haskell.org/platform/ - - -2.1 Installing tamarin-prover ----------------------------- - - You need a working Haskell environment that provides GHC 7 and the 'cabal - install' tool. The simplest way to get such an environment is to download and - install the Haskell Platform package for your OS. - - http://hackage.haskell.org/platform/ - - Then call - - cabal install - - in the root directory of this source code package. This will use the - Haskell's deployment tool 'cabal-install' to download all missing libraries - from Hackage, the central Haskell library repository and install the - 'tamarin-prover' executable in the default installation location of - cabal-install. The installation location is printed at the end of the build - process. Note that this may take a long time due to the large number of - dependencies of the built-in webserver used to serve the interactive mode. - - -3. Usage -======== - -the tamarin-prover can be used in two modes: - - (1) a batch mode where it just tries to parse the given file (and if called - with --prove) to prove their specified lemmas. - - (2) an interactive mode, which runs a webserver that allows to construct - and explore security proofs interactively. - This mode has to be run with an argument that specifies directory - containing the protocol models to be investigated. - -See the help message output when calling 'tamarin-prover' without any flags -for more information. - - - -4. Built-in Equational theories -=============================== - -There are several built-in equational theories which can be activated -for a given theory file by including: - -> builtin: theoryname - -The following theories are supported as builtins: - -diffie-hellman: - functions: _ ^ _, inv(_), _*_ - equations: see paper - -hashing: - functions: h(_) - no equations - -signing: - functions: sign(_,_), verify(_,_,_), pk(_), true - equations: verify(sign(m,sk), m, pk(sk)) = true - -symmetric-encryption: - functions: senc(_,_), sdec(_,_) - equations: sdec(senc(m,k),k) = m - -asymmetric-encryption: - functions: aenc(_,_), adec(_,_), pk(_) - equations: adec(aenc(m, pk(sk)), sk) = m - - -*** -* Happy Proving :-) -* -* In case of questions do not hesistate to contact the authors -* simon.meier@inf.ethz.ch or benedikt.schmidt@inf.ethz.ch -*** diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,93 @@ import Distribution.Simple main = defaultMain + +{- Inferring the package version from git. Posted by https://github.com/hvr + - + - https://gist.github.com/656738 + +import Control.Exception +import Control.Monad +import Data.Maybe +import Data.Version +import Distribution.PackageDescription (PackageDescription(..), HookedBuildInfo, GenericPackageDescription(..)) +import Distribution.Package (PackageIdentifier(..)) +import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, UserHooks(..)) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Setup (BuildFlags(..), ConfigFlags(..)) +import Distribution.Simple.Utils (die) +import System.Process (readProcess) +import Text.ParserCombinators.ReadP (readP_to_S) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { confHook = myConfHook + , buildHook = myBuildHook + } + +-- configure hook +myConfHook :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +myConfHook (gpdesc, hbinfo) cfg = do + let GenericPackageDescription { + packageDescription = pdesc@PackageDescription { + package = pkgIden }} = gpdesc + + gitVersion <- inferVersionFromGit (pkgVersion (package pdesc)) + + let gpdesc' = gpdesc { + packageDescription = pdesc { + package = pkgIden { pkgVersion = gitVersion } } } + + -- putStrLn $ showVersion gitVersion + + confHook simpleUserHooks (gpdesc', hbinfo) cfg + + +-- build hook +myBuildHook :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () +myBuildHook pdesc lbinfo uhooks bflags = do + let lastVersion = pkgVersion $ package pdesc + + gitVersion <- inferVersionFromGit lastVersion + + when (gitVersion /= lastVersion) $ + die("The version reported by git '" ++ showVersion gitVersion ++ + "' has changed since last time this package was configured (version was '" ++ + showVersion lastVersion ++ "' back then), please re-configure package") + + buildHook simpleUserHooks pdesc lbinfo uhooks bflags + +-- |Infer package version from Git tags. Uses `git describe` to infer 'Version'. +inferVersionFromGit :: Version -> IO Version +inferVersionFromGit version0 = do + ver_line <- init `liftM` readProcess "git" + [ "describe" + , "--abbrev=5" + , "--tags" + , "--match=v[0-9].[0-9][0-9]" + , "--dirty" + , "--long" + , "--always" + ] "" + + -- ver_line <- return "v0.1-42-gf9f4eb3-dirty" + putStrLn ver_line + -- let versionStr = ver_line -- (head ver_line == 'v') `assert` replaceFirst '-' '.' (tail ver_line) + -- Just version = listToMaybe [ p | (p, "") <- readP_to_S parseVersion versionStr ] + + return version0 + +{- +-- | Helper for replacing first occurence of character by another one. +replaceFirst :: Eq a => a -> a -> [a] -> [a] +replaceFirst _ _ [] = [] +replaceFirst o r (x:xs) | o == x = r : xs + | otherwise = x : replaceFirst o r xs +-} + +-} diff --git a/data/AUTHORS b/data/AUTHORS --- a/data/AUTHORS +++ b/data/AUTHORS @@ -3,5 +3,5 @@ Simon Meier Contributors: - protocol models: Cas Cremers - web interface: Cedric Staub + original web interface: Cedric Staub , + Benedikt Schmidt + + +Installation +============ + +See http://www.infsec.ethz.ch/research/software#TAMARIN for detailed +installation instructions for Linux and Mac. The Tamarin prover also runs on +Windows. Drop us a mail, if you would like access to a precompiled binary. + + +Syntax highlighting +------------------- + +We provide syntax highlighting files for the 'vim' text editor. Here, we +describe how to install them. Let DATA_PATH be the parent directory of the +examples directory output in Tamarin's help message. The 'vim' syntax +highlighting files are found at + + DATA_PATH/etc/ + +To install them, copy 'DATA_PATH/etc/filepath.vim' to the '~/.vim' directory +and copy 'DATA_PATH/etc/spthy.vim' to the '~/.vim/syntax directory'. If one of +these directories does not exist, then just create it. + + +Usage +===== + +Once you have installed the 'tamarin-prover' executable, calling it without +any arguments will print a help message explaining its different modes and the +paths to example files. We suggest that you first have a look at the +'Tutorial.spthy' file referenced there. + +Once, you have done that, you probably want to start modeling your own +protocols. We normally use the following workflow to do that. + + 1. Copy the example protocol that is most similar to the one your are + modeling. Let us assume that this copy is named 'myproto.spthy'. + + 2. Modify the protocol a bit and call 'tamarin-prover myproto.spthy' to + ensure that it still parses and all well-formedness checks pass. This + way you get immediate feedback on your changes. Moreover, you can see the + expansions of syntactic sugar like the built-in signatures for hashing or + asymmetric encryption. + + 3. Once you are satisfied with your model, check if the automated prover + succeeds in analyzing your protocol by calling + + 'tamarin-prover myproto.spthy --prove' + + 4. If the Tamarin prover does not terminate, then you can either bound the + proof-depth using the '--bound' flag or you can switch to the interactive + GUI to analyze what is going wrong. Call + + 'tamarin-prover interactive myproto.spthy' + + and try to construct the proof interactively. + + Note that you can also use the GUI to sanity check your model. Just go + through the message theory and check that it really models what you + intent to model. Moreover, the precomputed case distinctions, described + below, give a good overview about the behaviour/specification of your + protocol. If something is wrong with your model, then it is likely that + you can see it already from the precomputed case distinctions. + + + +Additional Theory +================= + +Most of the theory behind the Tamarin prover is described in our CSF 2012 +paper, whose extended version is available from + + http://www.infsec.ethz.ch/research/software#TAMARIN + +The implementation exploits a slightly refined theory, which allows to store +multiple constraint reduction steps in the form of *precomputed case +distinctions* and which allows to delay the enumeration of the finite variants +of multiset rewriting rules using an *equation store*. We explain these two +components below. We also give a sneak-peek preview on the theory we have +developed for dealing with loop-invariants. + + +Precomputed Case Distinctions +----------------------------- + +Apart from unification, the most common step performed by Tamarin is the +enumeration of the possible origins of an open premise. Most of these +backwards steps result in a number of trivial further constraint reduction +steps being applied immediately. Instead of applying them over and over during +proof/counter-example construction, we precompute the result of doing one +backwards step and use the resulting precomputed case distinctions during +proof/counter-example search. + +This precomputation is sound because the applicability of all our constraint +reduction rules is invariant under set union and instantiation. We precompute +cases for an arbitrary instance of every protocol fact and every outermost +constructor of a message. + + +Equation Store +-------------- + +We store equations in a special form to allow delaying case splits on them. +This allows for example to determine the shape of a signed message without case +splitting on its variants. In the GUI, you can see the equation store being +pretty printed as follows. + + free-substitution + + 1. fresh-substitution-group + ... + n. fresh substitution-group + +The free-substitution represents the equalities that hold for the free +variables in the constraint system in the usual normal form, i.e., a +substitution. The variants of a protocol rule are represented as a group of +substitutions mapping free variables of the constraint system to terms +containing only fresh variables. The different fresh-substitutions in a group +are interpreted as a disjunction. + +Logically, the equation store represents expression of the form + + x_1 = t_free_1 + & ... + & x_n = t_free_n + & ( (Ex y_111 ... y_11k. x_111 = t_fresh_111 & ... & x_11m = t_fresh_11m) + | ... + | (Ex y_1l1 ... y_1lk. x_1l1 = t_fresh_1l1 & ... & x_1lm = t_fresh_1lm) + ) + & .. + & ( (Ex y_o11 ... y_o1k. x_o11 = t_fresh_o11 & ... & x_o1m = t_fresh_o1m) + | ... + | (Ex y_ol1 ... y_olk. x_ol1 = t_fresh_ol1 & ... & x_1lm = t_fresh_1lm) + ) + + +(Loop) Invariants +----------------- + +The normal form conditions that we impose on dependency graphs can be seen as +a strong invariant on security protocol execution. As we have shown in our +case studies many security properties follow from these normal form +conditions. However, for some protocols additional invariants are necessary to +prove their security properties. + +We can formalize such invariants by specifying them as trace formulas. We can +prove them using the induction scheme associated to the traces of a protocol. +We using this induction scheme in the form of a trace formula conversion that +converts a guarded trace formula \phi to a semantically equivalent formula +\phi_{inductive}. This formula \phi_{inductive} is again a guarded trace +formula. It is easier to prove because it contains the induction hypothesis in +a weakened form. Semantically, the formula \phi_{inductive} states that we are +looking for counter-examples that are minimal with respect to the prefix-order +on traces. + +You can apply induction by clicking on the 'induction' proof method in the +GUI or adding the [inductive] attribute to a lemma. An example protocol whose +proof require induction is given in 'examples/stable/InvariantsExample.spthy'. + + + +Security Protocol Theories +========================== + +A security protocol theory specifies a signature, an equational theory, a +security protocol, and several lemmas, which formalize security properties. +The paper explaining the theory behind Tamarin has been published at CSF 2012 +and its extended version is available from + + http://www.infsec.ethz.ch/research/software#TAMARIN + +Here, we explain the formal syntax of the security protocol theory format that +is processed by Tamarin. We recommend first reading the 'Tutorial.spthy' +example before delving into the following section. + +Comments are C-style: + + /* for a multi-line comment */ + // for a line-comment + +All security protocol theory are named and delimited by 'begin' and 'end'. +We explain the non-terminals of the body in the following paragraphs. + + security_protocol_theory := 'theory' ident 'begin' body 'end' + body := (signature_spec | rule | lemma | formal_comment)+ + +Here, we use the term signature more liberally to denote both the defined +function symbols and the equalities describing their interaction. Note that +our parser is stateful and remembers what functions have been defined. It will +only parse function applications of defined functions. + + signature_spec := functions | equations | built_in + functions := 'functions' ':' (ident '/' arity) list + equations := 'equations' ':' (term '=' term) list + arity := digit+ + +Note that the equations must be subterm-convergent. Tamarin provides built-in +sets of function definitions and subterm convergent equations. They are +expanded upon parsing and you can therefore inspect them by pretty printing +the file using 'tamarin-prover your_file.spthy'. The built-in 'diffie-hellman' +is special. It refers to the equations given in the paper. You need to enable +it to parse terms containing exponentiations, e.g., g ^ x. + + built_in := 'builtins' ':' built_ins list + built_ins := 'diffie-hellman' + | 'hashing' | 'symmetric-encryption' + | 'asymmetric-encryption' | 'signing' + +Multiset rewriting rules are specified as follows. The protocol corresponding +to a security protocol theory is the set of all multiset rewriting rules +specified in the body of the theory. + + rule := 'rule' ident ':' + [let_block] + '[' facts ']' ( '-->' | '--[' facts ']->') '[' facts ']' + + let_block := 'let' (ident '=' term)+ 'in' + +The let-block allows more succinct specifications. The equations are applied +in a bottom-up fashion. For example, + + let x = y + y = + in [] --> [ A(y)] is desugared to [] --> [ A() ] + +This becomes a lot less confusing if you keep the set of variables on the +left-hand side separate from the free variables on the right-hand side ;-) + +Lemmas specify security properties. By default, the given formula is +interpreted as a property that must hold for all traces of the protocol of the +security protocol theory. You can change this using the 'exists-trace' trace +quantifier. + + lemma := 'lemma' ident [lemma_attrs] ':' + [trace_quantifier] + '"' formula '"' + lemma_attrs := '[' ('typing' | 'reuse' | 'inductive') ']' + trace_quantifier := 'all-traces' | 'exists-trace' + + +Formal comments are used to make the input more readable. In contrast +to /*...*/ and //... comments, formal comments are stored and output +again when pretty-printing a security protocol theory. + + formal_comment := ident '{*' ident* '*}' + +For the syntax of terms, you best look at our examples. A common pitfall is to +use an undefined function symbol. This results in an error message pointing to +a position slightly before the actual use of the function due to some +ambiguity in our grammar. + +We provide special syntax for tuples, multiplications, exponentiation, nullary +and binary function symbols. An n-ary tuple is parsed as n-ary, +right-associative application of pairing. Multiplication and exponentiation +are parsed left-associatively. For a binary operator 'enc' you can write +'enc{m}k' or 'enc(m,k)'. For nullary function symbols, there is no need to +write 'nullary()'. Note that the number of arguments of an n-ary function +application must agree with the arity given in the function definition. + + tupleterm := multterm list + multterm := expterm ('*' expterm)* + expterm := term ('^' term )* + term := '<' tupleterm '>' // n-ary right-associative pairing + | '(' multterm ')' // a nested term + | nullary_fun + | binary_app + | nary_app + | literal + + nullary_fun := + binary_app := binary_fun '{' tupleterm '}' term + binary_fun := + nary_app := nary_fun '(' multterm* ')' + + literal := "'" ident "'" // a fixed, public name + | '$' ident // a variable of sort 'pub' + | "~'" ident "'" // a fixed, fresh name + | "~" ident // a variable of sort 'fresh' + | "#" ident // a variable of sort 'temp' + | ident // a variable of sort 'msg' + +Facts do not have to be defined up-front. This will probably change once we +implement user-defined sorts. Facts prefixed with '!' are persistent facts. +All other facts are linear. There are six reserved fact symbols: In, Out, KU, +KD, K, and Ded. KU and KD facts are used for construction and deconstruction +rules. The 'Ded' fact logs the messages deduced by construction rules. See the +InductionInvariant.spthy example for more information. + + facts := fact list + fact := ['!'] ident '(' multterm list ')' + +Formulas are trace formulas as described in our paper. Note that we are a bit +more liberal with respect to guardedness. We accept a conjunction of atoms as +guards. + + formula := atom | '(' iff ')' | ( 'All' | 'Ex' ) ident+ '.' iff + iff := imp '<=>' imp + imp := disjuncts '==>' disjuncts + disjuctions := conjuncts ('|' disjuncts)+ // left-associative + conjuncts := negation ('|' disjuncts)+ // left-associative + negation := 'not' formula + + atom := tvar '<' tvar // ordering of temporal variables + | '#' ident '=' '#' ident // equality between temporal variables + | multterm '=' multterm // equality between terms + | fact '@' tvar // action + | 'T' // true + | 'F' // false + | '(' formula ')' // nested formula + + // Where unambiguous the '#' sort prefix can be dropped. + tvar := ['#'] ident + +Identifiers always start with a character. Moreover, they must not be one of the +reserved keywords 'let', 'in', or 'rule'. + + ident := alpha (alpha | digit)* + + + +Developing Tamarin +================== + +The Tamarin prover is under active development. We are grateful to receive +bug-reports. If you consider building on top of Tamarin, then you might +consider integrating your idea into the main source repository. Please feel +free to contact us such that we can discuss the next steps towards fully +verified systems :-) + diff --git a/data/etc/spthy.vim b/data/etc/spthy.vim --- a/data/etc/spthy.vim +++ b/data/etc/spthy.vim @@ -51,7 +51,9 @@ syn match spthyConstr "\ - [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ] - -rule Reveal_ltk: - [ !Ltk(A, ltkA) ] --[ RevLtk(A) ]-> [ Out(ltkA) ] - - -/* We formalize the following signature based TLS handshake. - - protocol TLS { - 1. C -> S: C, nc, sid, pc - 2. C <- S: ns, sid, ps - - 3. C -> S: { '31', pms }pk(S) , - sign{ '32', h('32', ns, S, pms) }pk(C) , - { '33', sid, h('PRF', pms, nc, ns), - nc, pc, C, ns, ps, S - } - h('clientKey', nc, ns, h('PRF', pms, nc, ns)) - - 4. C <- S: { '4', sid, h('PRF', pms, nc, ns), - nc, pc, C, ns, ps, S - } - h('serverKey', nc, ns, h('PRF', pms, nc, ns)) - } -*/ - -rule C_1: - [ Fr(~nc) - , Fr(~sid) - ] - --[]-> - [ Out( - <$C, ~nc, ~sid, $pc> - ) - , St_C_1($C, ~nc, ~sid, $pc) - ] - -rule S_1: - [ In( - <$C, nc, sid, pc> - ) - , Fr(~ns) - ] - --[]-> - [ Out( - <$S, ~ns, sid, $ps> - ) - , St_S_1($S, $C, sid, nc, pc, ~ns, $ps) - ] - -rule C_2: - [ St_C_1(C, nc, sid, pc) - , In( - - ) - , Fr(~pms) - , !Pk(S, pkS) - , !Ltk(C, ltkC) - ] - --[]-> - [ Out( - < aenc{ '31', ~pms }pkS - , sign{ '32', h('32', ns, S, ~pms) }ltkC - , senc{ '33', sid, h('PRF', ~pms, nc, ns), nc, pc, C, ns, ps, S} - h('clientKey', nc, ns, h('PRF', ~pms, nc, ns)) - > - ) - , St_C_2(S, C, sid, nc, pc, ns, ps, ~pms) - ] - -rule S_2: - [ St_S_1(S, C, sid, nc, pc, ns, ps) - , In( - < aenc{ '31', pms }pk(ltkS) - , signature - , senc{ '33', sid, h('PRF', pms, nc, ns), nc, pc, C, ns, ps, S} - h('clientKey', nc, ns, h('PRF', pms, nc, ns)) - > - ) - , !Pk(C, pkC) - , !Ltk(S, ltkS) - ] - /* Explicit equality check, enforced as part of the property. */ - --[ Eq(verify(signature, <'32', h('32', ns, S, pms)>, pkC), true ) - , SessionKeys - ( S, C - , h('serverKey', nc, ns, h('PRF', pms, nc, ns)) - , h('clientKey', nc, ns, h('PRF', pms, nc, ns)) - ) - ]-> - [ Out( - senc{ '4', sid, h('PRF', pms, nc, ns), nc, pc, C, ns, ps, S} - h('serverKey', nc, ns, h('PRF', pms, nc, ns)) - ) - ] - -rule C_3: - [ St_C_2(S, C, sid, nc, pc, ns, ps, pms) - , In( - senc{ '4', sid, h('PRF', pms, nc, ns), nc, pc, C, ns, ps, S} - h('serverKey', nc, ns, h('PRF', pms, nc, ns)) - ) - ] - --[ SessionKeys - ( S, C - , h('serverKey', nc, ns, h('PRF', pms, nc, ns)) - , h('clientKey', nc, ns, h('PRF', pms, nc, ns)) - ) - ]-> - [] - - -/* TODO: Also model session-key reveals and adapt security properties. */ - - -/* Session key secrecy from the perspecitive of both the server and the client - * for both the key of the server and the key of the client. Note that this - * lemma thus captures four security properties at once. */ -lemma session_key_secrecy: - " /* If all equality checks succeeded */ - (All x y #i. Eq(x,y) @ i ==> x = y) - ==> - /* then there is no attack */ - (not( - /* It cannot be that */ - Ex S C keyS keyC #k. - /* somebody claims to have setup session keys, */ - SessionKeys(S, C, keyS, keyC) @ k - /* but the adversary knows one of them */ - & ( (Ex #i. K(keyS) @ i) - | (Ex #i. K(keyC) @ i) - ) - /* without having performed a long-term key reveal. */ - & not (Ex #r. RevLtk(S) @ r) - & not (Ex #r. RevLtk(C) @ r) - ) )" - -/* Consistency check: this lemma must NOT have a proof, - * as otherwise no session-keys could be setup between honest agents. */ -lemma session_key_setup_possible: - " /* If all equality checks succeeded */ - (All x y #i. Eq(x,y) @ i ==> x = y) - ==> - /* then there is no trace */ - (not( - /* It cannot be that */ - Ex S C keyS keyC #k. - /* somebody claims to have setup session keys, */ - SessionKeys(S, C, keyS, keyC) @ k - /* without having performed a long-term key reveal. */ - & not (Ex #r. RevLtk(S) @ r) - & not (Ex #r. RevLtk(C) @ r) - ) )" - - -end - diff --git a/data/examples/UserGuide.spthy b/data/examples/UserGuide.spthy deleted file mode 100644 --- a/data/examples/UserGuide.spthy +++ /dev/null @@ -1,437 +0,0 @@ -/* -User guide to the tamarin prover for security protocol analysis -=============================================================== - -Authors: Simon Meier, Benedikt Schmidt -Date: February 2012 - - -Introduction ------------- - -This user guide assumes that you have a copy of our CSF'12 submission on -"Automated Analysis of Diffie-Hellman Protocols and Advanced Security -Properties". Drop us a mail, if you would like to receive a copy. - -The input files for the tamarin prover have the extension .spthy, which is -short for 'security protocol theory'. A security protocol theory specifies - - 1. the signature and equational theory to use for the message algebra, - 2. the set of set of multiset rewriting rules modeling the protocol and - the adversary capabilities, and - 3. the guarded trace properties whose validity for this set of multiset - rewriting rules we want to check. - -We explain each of these parts where they occur in the following security -protocol theory. Before we start, a few notes on the syntax. -As you probably noticed, comments are C-style. All identifiers are -case-sensitive. The parser is layout-insensitive, i.e., your are free to use -whitespace as it suits you. For people using the 'vim' text-editor, we provide -syntax highlighting files. We explain how to install them, before we explain -how to model a simple example protocol. - - -Installing the vim syntax highlighting files --------------------------------------------- - -As you've probably noticed, calling 'tamarin-prover' without any arguments -yields an informative help-message listing all available flags and the paths -to the installed example protocol files. We call the directory above the -example files the DATA_PATH. The examples are found at - - DATA_PATH/examples - -and the 'vim' syntax highlighting files are found at - - DATA_PATH/etc/ - -To install them, copy - - DATA_PATH/etc/filepath.vim - -to the ~/.vim directory and copy - - DATA_PATH/etc/spthy.vim - -to the ~/.vim/syntax directory. If one of these directories does not exist, -then just create it. - - - -Modeling a security protocol ----------------------------- - -Every security protocol theory starts with a header of the following form. -*/ - -theory UserGuide -begin - -/* -Obviously, you can replace 'UserGuide' with any name you like to give your -theory. After 'begin', you can declare function symbols, equations that they -must satisfy, multiset rewriting rules, and lemmas specifying security -properties. Moreover, you can also insert formal comments, to structure your -theory. We give examples of each of these elements while modeling the -a simple protocol. - -In this protocol a client C generates a fresh symmetric key 'k', encrypts it -with the public key of a server 'S' and sends it to 'S'. The server confirms -the receipt of the key by sending back its hash to the client. In -Alice-and-Bob notation the protocol would read as follows. - - C -> S: aenc{k}pk(S) - S <- C: h(k) - -This protocol is artificial and it satisfies only very weak security -guarantees. We can prove that from the perspective of the client, the freshly -generated key is secret provided that the server is uncompromised. - -We model this protocol in three steps. First, we declare the function symbols -and the equations defining them. Then, we introduce multiset rewriting rules -modeling a public key infrastructure (PKI) and the protocol. Finally, we state -the expected security properties. - - -Function Signature and Equational Theory ----------------------------------------- - -We model hashing using the unary function 'h'. -We model asymmetric encryption by declaring - a binary function 'aenc' denoting a call to the encryption algorithm, - a binary function 'adec' denoting a call to the decryption algorithm, and - a unary function 'pk' denoting a call to the algorithm computing a public - key from a private key. -*/ - -functions: h/1, aenc/2, adec/2, pk/1 -equations: adec(aenc(m, pk(k)), k) = m - -/* -The above equation then models the interaction between calls to these three -algorithms. All these equations must be subterm-convergent rewriting rules, -when read from left to right. This means that the right-hand-side must be a -subterm of the left-hand-side or a nullary function symbol. - -Certain equational theories are used very often when modeling cryptographic -messages. We therefore provide builtin definitions for them. The above theory -could also be enabled using the declaration - - builtin: hashing, asymmetric-encryption - -We support the following builtin theories: - - diffie-hellman, signing, asymmetric-encryption, symmetric-encryption, - hashing - -Apart from 'diffie-hellman', all of these theories are subterm-convergent and -can therefore also be declared directly, as above. You can inspect their -definitions by uncommenting the following two line-comments and calling - - tamarin-prover UserGuide.spthy - -*/ - -// builtin: diffie-hellman, signing, asymmetric-encryption, symmetric-encryption, -// hashing - -/* -The call 'tamarin-prover UserGuide.spthy' parses the UserGuide.spthy file, -computes the variants of the multiset rewriting rules and checks their -wellformedness (explained below), and pretty-prints the theory. The -declaration of the signature and the equations can be found at the top of the -pretty-printed theory. - -Proving all lemmas contained in the theory would be as simple as adding the -flag '--prove' to the call; i.e., - - tamarin-prover UserGuide.spthy --prove - -However, let's not go there yet. We first have to model the PKI and our -protocol. - -Modeling the Public Key Infrastructure --------------------------------------- -*/ - -// Registering a public key -rule Register_pk: - [ Fr(~ltk) ] - --> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)) ] - -/* The above rule models registering a public key. It makes use of the - following syntax. - - Facts always start with an upper-case letter. They are declared implicitly. - If their name is prefixed with an exclamation mark '!', then they are - persistent. Otherwise, they are linear. Note that you must use every fact - name consistently; i.e., you must always use it with the same arity, casing, - and multiplicity. Otherwise, the tamarin prover complains that the theory - is not wellformed. - - The 'Fr' fact is a builtin fact. It denotes a freshly generated fresh name. - See the paper for details. - - We denote the sort of variables using prefixes: - - ~x denotes x:fresh - $x denotes x:pub - #i denotes i:temp - i denotes i:msg - - 'c' denotes a public name 'c \in PN'; i.e., a fixed, global constant - - Thus, the above rule can be read as follows. First, freshly generate a - fresh name 'ltk', the new private key and nondeterministically choose a - public name 'A', the agent for which we are generating the key-pair. - Then, generate the persistent fact !Ltk($A, ~ltk), which denotes the - association between agent 'A' and its private key 'ltk, and generate the - persistent fact !Pk($A, pk(~ltk)), which denotes the association between the - agent 'A' and its public key 'pk(~ltk)'. - - We allow the adversary to retrieve any public key using the following rule. - Intuitively, it just reads a public-key database entry and sends the public - key to the network using the builtin fact 'Out' denoting a message sent to - the network. See our paper for more information. -*/ - -rule Get_pk: - [ !Pk(A, pk) ] - --> - [ Out(pk) ] - -/* - We model dynamic compromise of long-term private keys using the following - rule. Intuitively, it reads a private-key database entry and sends it to - the adversary. This rule has an observable 'LtkReveal' action stating that - the long-term key of agent 'A' was compromised. We will use this action in - the security property below to determine which agents are compromised. -*/ - -rule Reveal_ltk: - [ !Ltk(A, ltk) ] - --[ LtkReveal(A) ]-> - [ Out(ltk) ] - - -/* - -Modeling the protocol ----------------------- - -Recall that we want to model the following protocol. - - C -> S: aenc{k}pk(S) - S <- C: h(k) - -We model it use the following three rules. -*/ - -// Start a new thread executing the client role, choosing the server -// non-deterministically. -rule Client_1: - [ Fr(~k) // choose fresh key - , !Pk($S, pkS) // lookup public-key of server - ] - --> - [ Client_1( $S, ~k ) // Store server and key for next step of thread - , Out( aenc{'1', ~k}pkS ) // Send the encrypted session key to the server - // We add the tag '1' to the request to allow - // the server to check whether the decryption - // was successful. - ] - -rule Init_2: - [ Client_1(S, k) // Retrieve server and session key from previous step - , In( h(k) ) // Receive hashed session key from network - ] - --[ SessKeyC( S, k ) ]-> // State that the session key 'k' - [] // was setup with server 'S' - -// A server thread answering in one-step to a session-key setup request from -// some client. -rule Serv_1: - [ !Ltk($S, ~ltkS) // lookup the private-key - , In( request ) // receive a request - ] - --[ Eq(fst(adec(request, ~ltkS)), '1') - , AnswerRequest($S, snd(adec(request, ~ltkS))) // Explanation below - ]-> - [ Out( h(snd(adec(request, ~ltkS))) ) ] // Return the hash of the - // decrypted request. - -/* Above, we model all applications of cryptographic algorithms explicitly. - Call 'tamarin-prover UserGuide.spthy' to inspect the finite variants of the - Serv_1 rule, which list all possible interactions of the destructors used. - In our proof search, we will consider all these interactions. - - We also model that the server explicitly checks that the first component of - the request is equal to '1'. We model this by logging the claimed equality - and then adapting the security property such that it only considers traces - where all 'Eq' actions occur with two equal arguments. Note that 'Eq' is NO - builtin fact. Guarded trace properties are strong enough to formalize this - requirement without builtin support. - - We log the session-key setup requests received by servers to allow - formalizing the authentication property for the client. - - -Modeling the security properties --------------------------------- - -The syntax for specifying security properties uses - - All for universal quantification, temporal variables are prefixed with # - Ex for existential quantification, temporal variables are prefixed with # - ==> for implication - & for conjunction - | for disjunction - not for negation - - f @ i for action constraints, the sort prefix for the temporal variable 'i' - is optional - - i < j for temporal ordering, the sort prefix for the temporal variable 'i' - is optional - - #i = #j for an equality between temporal variables 'i' and 'j' - x = y for an equality between message variables 'x' and 'y' - -Note that apart from public names (delimited using single-quotes), no terms -may occur in guarded trace properties. Moreover, all variables must be -guarded. The error message for an unguarded variable is currently not very -good. - -For universally quantified variables, one has to check that they all occur in -an action constraint right after the quantifier and that the toplevel inside -the quantifier is an implication. -For existentially quantified variables, one has to check that they all occur in -an action constraint right after the quantifier and that the toplevel inside -the quantifier is a conjunction. -Note also that currently the precedence of the logical connectives is not -specified. We therefore recommend to use parentheses, when in doubt. - - -The following two properties should be self-explanatory. -*/ - -lemma Client_session_key_secrecy: - " /* For all traces, where all equality checks succeed, */ - (All x y #i. Eq(x,y) @ i ==> x = y) - ==> - /* it cannot be that a */ - not( - Ex S k #i #j. - /* client setup a session key 'k' with a server'S' */ - SessKeyC(S, k) @ #i - /* and the adversary knows 'k' */ - & K(k) @ #j - /* without having performed a long-term key reveal on 'S'. */ - & not(Ex #r. LtkReveal(S) @ r) - ) - " - - -lemma Client_auth: - " /* For all traces, where all equality checks succeed, */ - (All x y #i. Eq(x,y) @ i ==> x = y) - ==> - /* for all session keys 'k' setup by clients with a server 'S' */ - ( All S k #i. SessKeyC(S, k) @ #i - ==> - /* there is a server that answered the request */ - ( (Ex #a. AnswerRequest(S, k) @ a) - /* or the intruder performed a long-term key reveal on 'S' - before the key was setup. */ - | (Ex #r. LtkReveal(S) @ r & r < i) - ) - ) - " - -/* - You can verify them by calling - - tamarin-prover --prove UserGuide.spthy - - This will first output some logging from the constraint solver and then the - UserGuide security protocol theory with the lemmas and their attached - (dis)proofs. - - Finding attacks is very useful, to check that a security property is not - trivial due to too strong preconditions. The following property must not be - provable, as otherwise there would be no possibility to setup a session key - with a honest sever. - -*/ - -// Must not be provable! -lemma Client_session_key_honest_setup_possible: - " (All x y #i. Eq(x,y) @ i ==> x = y) - ==> - not( - Ex S k #i. - SessKeyC(S, k) @ #i - & not(Ex #r. LtkReveal(S) @ r) - ) - " - -/* As you can see from the output of - - tamarin-prover --prove UserGuide.spthy - - It finds an "attack" on this property, as expected. To characterize all - possible attacks use - - tamarin-prover --prove --stop-on-attack=NONE UserGuide.spthy - - You can see from the output that there is exactly one way to setup a session - key with an honest server. - - -Interactive proof visualization and construction ------------------------------------------------- - -Just call - - tamarin-prover interactive UserGuide.spthy - -This will start a web-server that loads all security protocol theories in the -same directory as UserGuide.spthy. Point your browser to - - http://localhost:3001 - -and explore the the UserGuide theory interactively by clicking on the -'UserGuide' entry in the table of loaded theories. You can prove a lemma -interactively by clicking on the available proof methods (corresponding to -applications of constraint reduction rules) or by calling the 'autoprover' by -right-clicking on a node in the theory overview. - - -Conclusion ----------- - -The case studies from our CSF'12 submission should now be readable. Recall -that you can find them in the directory listed at the bottom of the help -message, when calling 'tamarin-prover' without any arguments. If you have -further questions, please do not hesitate to contact either - - Benedikt Schmidt benedikt.schmidt@inf.ethz.ch - Simon Meier simon.meier@inf.ethz.ch. - -Note that our CSF'12 submission does not explain how we compose multiple -constraint reduction into a precomputed case distinction. It also does not -explain how we delay splitting on the different variants of multiset rewriting -rules. We will report on this in an upcoming technical report. This report -will also explain the support for proving loop invariants by induction, as it -is already supported by this version of 'tamarin'. - - -BTW, every security protocol theory must be delimited with 'end'. - - (-: HAPPY PROVING :-) -*/ - -end - - diff --git a/data/examples/csf12/Artificial.spthy b/data/examples/csf12/Artificial.spthy --- a/data/examples/csf12/Artificial.spthy +++ b/data/examples/csf12/Artificial.spthy @@ -12,19 +12,19 @@ illustrate constraint solving and characterization. Note that, for characerization, you have to call the tamarin-prover as follows. - tamarin-prover --prove --stop-on-attack=NONE your_protocol.spthy + tamarin-prover --prove --stop-on-trace=NONE your_protocol.spthy - The --stop-on-attack=NONE flag ensures that all solved constraint systems + The --stop-on-trace=NONE flag ensures that all solved constraint systems are explored by the constraint solver. By default, it stops as soon as the - first attack is found. Note that depending on the protocol, + first trace is found. Note that depending on the protocol, characterization might take a long time, as there are many slightly - different possible attacks. + different possible traces. As a more interesting example try characterizing the setup of a session-key between two honest agents in the TLS.spthy example, which models a TLS handshake using signatures. - tamarin-prover --prove --stop-on-attack=NONE TLS.spthy +RTS -N + tamarin-prover --prove --stop-on-trace=NONE TLS.spthy +RTS -N Note that we add the +RTS -N to tell the Haskell runtime system that it should use as many cores as your system provides. For TLS, this speeds-up @@ -33,14 +33,14 @@ finding all counter-examples to this property. Exactly, two of the cases will be of the form - SOLVED (trace found) + SOLVED // trace found They correspond to the _only_ two ways of setting up a session-key between honest agents: one for the client and one for the server. */ -builtin: symmetric-encryption +builtins: symmetric-encryption rule Step1: [ Fr(~x), Fr(~k) ] @@ -57,8 +57,9 @@ --[ Rev(k) ]-> [ Out(k) ] +// We search for trace-existence, as we want to characterize the possible +// traces satisfying the given formula. lemma Characterize_Fin: - "not( Ex k S #i. Fin(S, k) @ i ) - " + exists-trace "Ex k S #i. Fin(S, k) @ i" end diff --git a/data/examples/csf12/DH2_original.spthy b/data/examples/csf12/DH2_original.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/DH2_original.spthy @@ -0,0 +1,144 @@ +theory DH2_original +begin + +builtins: diffie-hellman, hashing + +section{* DH2 *} + +/* + * Protocol: DH2 + * Modeler: Cas Cremers + * Date: April 2012 + * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol" + * Chatterjee, Menezes, Ustaoglu, 2011 + * Model: Original model from the above paper + * (a restricted version of eCK) + * + * Status: working + * + * Notes: Slightly simplified to use only a single group 'g' instead of allowing participants to choose. + */ + +functions: KDF/1 +functions: MAC/2 + +/* Protocol rules */ + +/* Generate long-term keypair */ +rule Register_pk: + let pkA = 'g'^~ltkA + in + [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ] + +/* Initiator */ +rule Init_1: + let pkR = 'g'^~ltkR + X = 'g'^~m1 + XB = pkR^~m1 + in + [ Fr( ~m1 ), !Ltk( $I, ~ltkI ), !Pk($R,pkR) ] + --[ Sid( ~m1, $I, $R, <$I, $R, 'Init', XB>) + , EphKey ( ~m1, ~m1 ) ]-> + [ Init_1( ~m1, $I, $R, ~ltkI, X, XB ), !Ephk( ~m1,~m1 ), Out( XB ) ] + +rule Resp_1: + let pkI = 'g'^~ltkI + Y = 'g'^~m2 + YA = pkI^~m2 + X = XB^inv(~ltkR) + key = KDF(< X, Y, $I, $R, XB, YA >) + tagB = MAC(key, (< 'Resp', $R, $I, YA, XB >) ) + tagA = MAC(key, (< 'Init', $I, $R, XB, YA >) ) + in + [ Fr( ~m2 ), In( XB ), !Ltk( $R, ~ltkR ), !Pk($I,pkI) ] + --[ Sid ( ~m2, $R, $I, <$R, $I, 'Resp', YA, XB >) + , Match( ~m2, <$I, $R, 'Init', XB >) + //, Match( ~m2, <$I, $R, 'Init', XB, YA >) // Case subsumed: if + // a matching Sid fact exists, then also a Sid fact exists that + // matches the previous + , EphKey ( ~m2, ~m2 ) + ]-> + [ Resp_1( ~m2, $I, $R, YA, XB, tagA, key ), !Ephk( ~m2,~m2 ), Out(< YA , tagB >) ] + +rule Init_2: + let pkR = 'g'^~ltkR + Y = YA^inv(~ltkI) + key = KDF(< X, Y, $I, $R, XB, YA >) + tagB = MAC(key, (< 'Resp', $R, $I, YA, XB >) ) + tagA = MAC(key, (< 'Init', $I, $R, XB, YA >) ) + in + [ Init_1( ~m1, $I, $R, ~ltkI, X, XB ) , In(< YA, tagB >) ] + --[ Sid ( ~m1, $I, $R, <$I, $R, 'Init', XB, YA > ) + , Match( ~m1, <$R, $I, 'Resp', YA, XB > ) + , Accept( ~m1, $I, $R, key) + ]-> + [ Out(< YA, XB, tagA >), !Sessk( ~m1, key ) ] + +rule Resp_2: + [ Resp_1( ~m2, $I, $R, YA, XB, tagA, key), In(< YA, XB, tagA >) ] + --[ Accept( ~m2, $R, $I, key) ]-> + [ !Sessk( ~m2, key ) ] + + + +/* Key Reveals for the eCK model */ +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ltk_reveal: + [ !Ltk($A, lkA) ] + --[ LtkRev($A) ]-> + [ Out(lkA) ] + +rule Ephk_reveal: + [ !Ephk(~s, ~ek) ] + --[ EphkRev(~s) ]-> + [ Out(~ek) ] + + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 #i3 #i4 s ss k A B minfo. + Accept(s, k) @ i1 + & Accept(ss, k) @ i2 + & Sid(s, A, B, minfo) @ i3 + & Match(ss, minfo) @ i4 + )" +*/ + +lemma KAS_key_secrecy: + "not (Ex #i1 #i2 s A B k . + Accept(s, A, B, k) @ i1 & K( k ) @ i2 + + /* No session-key-reveal of test thread. */ + & not(Ex #i4. SesskRev( s ) @ i4 ) + + /* If matching session exists (for all matching sessions...) */ + & (All ss #i4 #i5 C D ms. + ( Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5) + ==> + ( not(Ex #i6 . SesskRev( ss ) @ i6 ) + & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & EphkRev ( s ) @ i7 ) + & not(Ex #i6 #i7. LtkRev ( B ) @ i6 & EphkRev ( ss ) @ i7 ) + & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & LtkRev ( B ) @ i7 ) + & not(Ex #i6 #i7. EphkRev ( s ) @ i6 & EphkRev ( ss ) @ i7 ) + ) + ) + + /* No matching session exists */ + & ( ( not(Ex ss #i4 #i5 C D ms. + Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) ) + ==> + ( not(Ex #i6. EphkRev ( s ) @ i6 ) + & not(Ex #i6. LtkRev ( B ) @ i6 & i6 < i1 ) + ) + ) + )" + +end diff --git a/data/examples/csf12/JKL_TS1_2004-KI.spthy b/data/examples/csf12/JKL_TS1_2004-KI.spthy deleted file mode 100644 --- a/data/examples/csf12/JKL_TS1_2004-KI.spthy +++ /dev/null @@ -1,116 +0,0 @@ -theory JKL_TS1_2004 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS1 (2004) *} - -/* - * Protocol: JKL-TS1-2004 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2004. - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, ~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ), - !Ephk(~ekI), - Out( ~ekI ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, ~ekI, Y, - h( < ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]-> - [ !Sessk( ~ekI, - h( < ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ] - -rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, ~ekR , - h( < X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]-> - [ Out( ~ekR ), - !Ephk(~ekR), - !Sessk( ~ekR, - h( < X, ~ekR, ('g'^~lkI)^~lkR > ) ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -end diff --git a/data/examples/csf12/JKL_TS1_2004_KI.spthy b/data/examples/csf12/JKL_TS1_2004_KI.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/JKL_TS1_2004_KI.spthy @@ -0,0 +1,126 @@ +theory JKL_TS1_2004_KI +begin + +builtins: hashing, diffie-hellman + +section{* Jeong, Katz, Lee : TS1 (2004) *} + +/* + * Protocol: JKL-TS1-2004 + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" + * Jeong, Katz, Lee, 2004. + * + * Status: working + */ + +/* Protocol rules */ + +rule generate_ltk: + let pkA = 'g'^~lkA + in + [ Fr(~lkA) ] --> + [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ] + +rule Init_1: + [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] + --[ SidI_1(~ekI,$I,$R, ~ekI ) + , NotEq($I,$R) // Inequality of names required, enforced in the property + ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ), + !Ephk(~ekI), + Out( ~ekI ) ] + +rule Init_2: + let pkR = 'g'^~lkR + key = h( < ~ekI, Y, pkR^~lkI > ) + in + [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R, pkR ) ] + --[SidI_2( ~ekI, $I, $R, ~ekI, Y, key) ]-> + [ !Sessk( ~ekI, key ) ] + +rule Resp_1: + let pkI = 'g'^~lkI + key = h( < X, ~ekR, pkI^~lkR > ) + in + [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, pkI) ] + --[ SidR_1( ~ekR, $I, $R, X, ~ekR, key) + , NotEq($I,$R) // Inequality of names required, enforced in the property + ]-> + [ Out( ~ekR ), + !Ephk(~ekR), + !Sessk( ~ekR, key) ] + +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ephk_reveal: + [ !Ephk(~ekI) ] + --[ EphkRev(~ekI) ]-> + [ Out(~ekI) ] + +rule Ltk_reveal: + [ !Ltk($A, k) ] + --[ LtkRev($A) ]-> + [ Out(k) ] + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_1_initiator_key: + "(not (Ex #i x . NotEq(x,x) @ i ) ) ==> // Only consider traces in which the inequalities hold + not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_1_responder_key: + "(not (Ex #i x . NotEq(x,x) @ i ) ) ==> + not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" + +end diff --git a/data/examples/csf12/JKL_TS1_2008-KI.spthy b/data/examples/csf12/JKL_TS1_2008-KI.spthy deleted file mode 100644 --- a/data/examples/csf12/JKL_TS1_2008-KI.spthy +++ /dev/null @@ -1,120 +0,0 @@ -theory JKL_TS1_2008 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS1 (2008) *} -/* - * Protocol: JKL-TS1-2008 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2008 - * Note: Although the paper title is the same as the 2004 - * original, the updated version from 2008 includes - * modified protocols and security models. - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, ~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ), - !Ephk(~ekI), - Out( ~ekI ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, ~ekI, Y, - h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]-> - [ !Sessk( ~ekI, - h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ] - -rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, ~ekR , - h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]-> - [ Out( ~ekR ), - !Ephk(~ekR), - !Sessk( ~ekR, - h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -end - diff --git a/data/examples/csf12/JKL_TS1_2008-KI_wPFS.spthy b/data/examples/csf12/JKL_TS1_2008-KI_wPFS.spthy deleted file mode 100644 --- a/data/examples/csf12/JKL_TS1_2008-KI_wPFS.spthy +++ /dev/null @@ -1,139 +0,0 @@ -theory JKL_TS1_2008 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS1 (2008) *} - -/* - * Protocol: JKL-TS1-2008 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2008 - * Note: Although the paper title is the same as the 2004 - * original, the updated version from 2008 includes - * modified protocols and security models. - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, ~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ), - !Ephk(~ekI), - Out( ~ekI ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, ~ekI, Y, - h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]-> - [ !Sessk( ~ekI, - h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ] - -rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, ~ekR , - h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]-> - [ Out( ~ekR ), - !Ephk(~ekR), - !Sessk( ~ekR, - h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the actor or intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) - */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - )" - -end - diff --git a/data/examples/csf12/JKL_TS1_2008_KI.spthy b/data/examples/csf12/JKL_TS1_2008_KI.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/JKL_TS1_2008_KI.spthy @@ -0,0 +1,120 @@ +theory JKL_TS1_2008_KI +begin + +builtins: hashing, diffie-hellman + +section{* Jeong, Katz, Lee : TS1 (2008) *} +/* + * Protocol: JKL-TS1-2008 + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" + * Jeong, Katz, Lee, 2008 + * Note: Although the paper title is the same as the 2004 + * original, the updated version from 2008 includes + * modified protocols and security models. + * + * Status: working + */ + +/* Protocol rules */ + +rule generate_ltk: + [ Fr(~lk) ] --> + [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] + +rule Init_1: + [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] + --[ SidI_1(~ekI,$I,$R, ~ekI ) ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ), + !Ephk(~ekI), + Out( ~ekI ) ] + +rule Init_2: + [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ] + --[SidI_2( ~ekI, $I, $R, ~ekI, Y, + h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]-> + [ !Sessk( ~ekI, + h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ] + +rule Resp_1: + [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] + --[ SidR_1( ~ekR, $I, $R, X, ~ekR , + h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]-> + [ Out( ~ekR ), + !Ephk(~ekR), + !Sessk( ~ekR, + h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ] + +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ephk_reveal: + [ !Ephk(~ekI) ] + --[ EphkRev(~ekI) ]-> + [ Out(~ekI) ] + +rule Ltk_reveal: + [ !Ltk($A, k) ] + --[ LtkRev($A) ]-> + [ Out(k) ] + + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_1_initiator_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_1_responder_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" + +end + diff --git a/data/examples/csf12/JKL_TS2_2004-KI.spthy b/data/examples/csf12/JKL_TS2_2004-KI.spthy deleted file mode 100644 --- a/data/examples/csf12/JKL_TS2_2004-KI.spthy +++ /dev/null @@ -1,117 +0,0 @@ -theory JKL_TS2_2004 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS2 (2004) *} -/* - * Protocol: JKL-TS2-2004 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2004 - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), - !Ephk(~ekI), - Out( 'g'^~ekI ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]-> - [ !Sessk( ~ekI, - h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ] - -rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]-> - [ Out( 'g'^~ekR ), - !Ephk(~ekR), - !Sessk( ~ekR, - h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -end diff --git a/data/examples/csf12/JKL_TS2_2004-KI_wPFS.spthy b/data/examples/csf12/JKL_TS2_2004-KI_wPFS.spthy deleted file mode 100644 --- a/data/examples/csf12/JKL_TS2_2004-KI_wPFS.spthy +++ /dev/null @@ -1,135 +0,0 @@ -theory JKL_TS2_2004 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS2 (2004) *} -/* - * Protocol: JKL-TS2-2004 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2004 - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), - !Ephk(~ekI), - Out( 'g'^~ekI ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]-> - [ !Sessk( ~ekI, - h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ] - -rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]-> - [ Out( 'g'^~ekR ), - !Ephk(~ekR), - !Sessk( ~ekR, - h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the actor or intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) - */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - )" - -end diff --git a/data/examples/csf12/JKL_TS2_2004_KI_wPFS.spthy b/data/examples/csf12/JKL_TS2_2004_KI_wPFS.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/JKL_TS2_2004_KI_wPFS.spthy @@ -0,0 +1,135 @@ +theory JKL_TS2_2004_KI_wPFS +begin + +builtins: hashing, diffie-hellman + +section{* Jeong, Katz, Lee : TS2 (2004) *} +/* + * Protocol: JKL-TS2-2004 + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" + * Jeong, Katz, Lee, 2004 + * + * Status: working + */ + +/* Protocol rules */ + +rule generate_ltk: + [ Fr(~lk) ] --> + [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] + +rule Init_1: + [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] + --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), + !Ephk(~ekI), + Out( 'g'^~ekI ) ] + +rule Init_2: + [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] + --[SidI_2( ~ekI, $I, $R, hkI, Y, + h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]-> + [ !Sessk( ~ekI, + h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ] + +rule Resp_1: + [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] + --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , + h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]-> + [ Out( 'g'^~ekR ), + !Ephk(~ekR), + !Sessk( ~ekR, + h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ] + +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ephk_reveal: + [ !Ephk(~ekI) ] + --[ EphkRev(~ekI) ]-> + [ Out(~ekI) ] + +rule Ltk_reveal: + [ !Ltk($A, k) ] + --[ LtkRev($A) ]-> + [ Out(k) ] + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ + + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_2_initiator_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_2_responder_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the actor or intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) + */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + )" + +end diff --git a/data/examples/csf12/JKL_TS2_2008-KI.spthy b/data/examples/csf12/JKL_TS2_2008-KI.spthy deleted file mode 100644 --- a/data/examples/csf12/JKL_TS2_2008-KI.spthy +++ /dev/null @@ -1,120 +0,0 @@ -theory JKL_TS2_2008 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS2 (2008) *} -/* - * Protocol: JKL-TS2-2008 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2008 - * Note: Although the paper title is the same as the 2004 - * original, the updated version from 2008 includes - * modified protocols and security models. - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), - !Ephk(~ekI), - Out( 'g'^~ekI ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]-> - [ !Sessk( ~ekI, - h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ] - -rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]-> - [ Out( 'g'^~ekR ), - !Ephk(~ekR), - !Sessk( ~ekR, - h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -end diff --git a/data/examples/csf12/JKL_TS2_2008-KI_wPFS.spthy b/data/examples/csf12/JKL_TS2_2008-KI_wPFS.spthy deleted file mode 100644 --- a/data/examples/csf12/JKL_TS2_2008-KI_wPFS.spthy +++ /dev/null @@ -1,139 +0,0 @@ -theory JKL_TS2_2008 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS2 (2008) *} -/* - * Protocol: JKL-TS2-2008 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2008 - * Note: Although the paper title is the same as the 2004 - * original, the updated version from 2008 includes - * modified protocols and security models. - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), - !Ephk(~ekI), - Out( 'g'^~ekI ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]-> - [ !Sessk( ~ekI, - h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ] - -rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]-> - [ Out( 'g'^~ekR ), - !Ephk(~ekR), - !Sessk( ~ekR, - h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the actor or intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) - */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - )" - -end diff --git a/data/examples/csf12/JKL_TS2_2008_KI_wPFS.spthy b/data/examples/csf12/JKL_TS2_2008_KI_wPFS.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/JKL_TS2_2008_KI_wPFS.spthy @@ -0,0 +1,139 @@ +theory JKL_TS2_2008_KI_wPFS +begin + +builtins: hashing, diffie-hellman + +section{* Jeong, Katz, Lee : TS2 (2008) *} +/* + * Protocol: JKL-TS2-2008 + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" + * Jeong, Katz, Lee, 2008 + * Note: Although the paper title is the same as the 2004 + * original, the updated version from 2008 includes + * modified protocols and security models. + * + * Status: working + */ + +/* Protocol rules */ + +rule generate_ltk: + [ Fr(~lk) ] --> + [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] + +rule Init_1: + [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] + --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), + !Ephk(~ekI), + Out( 'g'^~ekI ) ] + +rule Init_2: + [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] + --[SidI_2( ~ekI, $I, $R, hkI, Y, + h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]-> + [ !Sessk( ~ekI, + h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ] + +rule Resp_1: + [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] + --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , + h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]-> + [ Out( 'g'^~ekR ), + !Ephk(~ekR), + !Sessk( ~ekR, + h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ] + +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ephk_reveal: + [ !Ephk(~ekI) ] + --[ EphkRev(~ekI) ]-> + [ Out(~ekI) ] + +rule Ltk_reveal: + [ !Ltk($A, k) ] + --[ LtkRev($A) ]-> + [ Out(k) ] + + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ + + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_2_initiator_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_2_responder_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the actor or intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) + */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + )" + +end diff --git a/data/examples/csf12/JKL_TS3_2004-KI_wPFS.spthy-nonterm b/data/examples/csf12/JKL_TS3_2004-KI_wPFS.spthy-nonterm deleted file mode 100644 --- a/data/examples/csf12/JKL_TS3_2004-KI_wPFS.spthy-nonterm +++ /dev/null @@ -1,199 +0,0 @@ -theory JKL_TS3_2004 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS3 (2004) *} -/* - * Protocol: JKL-TS3-2004 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2004 - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ), Roles($I, $R) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), - !Ephk(~ekI), - Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,$I,$R,'g'^~ekI ) > ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR), - In( < Y, h(('g'^~lkI)^~lkR,$R,$I,Y )> ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - Y^~ekI ), Roles($I, $R) ]-> - [ !Sessk( ~ekI, - Y^~ekI ) ] - -rule Resp_1: - [ In( < X, h( ('g'^~lkR)^~lkI,$I,$R,X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - X^~ekR ), Roles($I, $R) ]-> - [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,$R,$I,'g'^~ekR ) > ), - !Ephk(~ekR), - !Sessk( ~ekR, - X^~ekR ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - - -/* Security properties */ - -/* Only non-reflected executions */ -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2 - - & (All #tid A. Roles(A, A) @ tid ==> F ) - )" -*/ - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2004_1_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Only non-reflected executions */ - & (All #tid A. Roles(A, A) @ tid ==> F ) - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -/* -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2004_1_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Only non-reflected executions */ - & (All #tid A. Roles(A, A) @ tid ==> F ) - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2004_2_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Only non-reflected executions */ - & (All #tid A. Roles(A, A) @ tid ==> F ) - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2004_2_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Only non-reflected executions */ - & (All #tid A. Roles(A, A) @ tid ==> F ) - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the actor or intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) - */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - )" -*/ -end diff --git a/data/examples/csf12/JKL_TS3_2004_KI_wPFS.spthy_nonterm b/data/examples/csf12/JKL_TS3_2004_KI_wPFS.spthy_nonterm new file mode 100644 --- /dev/null +++ b/data/examples/csf12/JKL_TS3_2004_KI_wPFS.spthy_nonterm @@ -0,0 +1,199 @@ +theory JKL_TS3_2004_KI_wPFS +begin + +builtin: hashing, diffie-hellman + +section{* Jeong, Katz, Lee : TS3 (2004) *} +/* + * Protocol: JKL-TS3-2004 + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" + * Jeong, Katz, Lee, 2004 + * + * Status: working + */ + +/* Protocol rules */ + +rule generate_ltk: + [ Fr(~lk) ] --> + [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] + +rule Init_1: + [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ] + --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ), Roles($I, $R) ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), + !Ephk(~ekI), + Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,$I,$R,'g'^~ekI ) > ) ] + +rule Init_2: + [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR), + In( < Y, h(('g'^~lkI)^~lkR,$R,$I,Y )> ) ] + --[SidI_2( ~ekI, $I, $R, hkI, Y, + Y^~ekI ), Roles($I, $R) ]-> + [ !Sessk( ~ekI, + Y^~ekI ) ] + +rule Resp_1: + [ In( < X, h( ('g'^~lkR)^~lkI,$I,$R,X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] + --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , + X^~ekR ), Roles($I, $R) ]-> + [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,$R,$I,'g'^~ekR ) > ), + !Ephk(~ekR), + !Sessk( ~ekR, + X^~ekR ) ] + +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ephk_reveal: + [ !Ephk(~ekI) ] + --[ EphkRev(~ekI) ]-> + [ Out(~ekI) ] + +rule Ltk_reveal: + [ !Ltk($A, k) ] + --[ LtkRev($A) ]-> + [ Out(k) ] + + +/* Security properties */ + +/* Only non-reflected executions */ +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2 + + & (All #tid A. Roles(A, A) @ tid ==> F ) + )" +*/ + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2004_1_initiator_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Only non-reflected executions */ + & (All #tid A. Roles(A, A) @ tid ==> F ) + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" + +/* +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2004_1_responder_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Only non-reflected executions */ + & (All #tid A. Roles(A, A) @ tid ==> F ) + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2004_2_initiator_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Only non-reflected executions */ + & (All #tid A. Roles(A, A) @ tid ==> F ) + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2004_2_responder_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Only non-reflected executions */ + & (All #tid A. Roles(A, A) @ tid ==> F ) + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the actor or intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) + */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + )" +*/ +end diff --git a/data/examples/csf12/JKL_TS3_2008-KI_wPFS.spthy-nonterm b/data/examples/csf12/JKL_TS3_2008-KI_wPFS.spthy-nonterm deleted file mode 100644 --- a/data/examples/csf12/JKL_TS3_2008-KI_wPFS.spthy-nonterm +++ /dev/null @@ -1,188 +0,0 @@ -theory JKL_TS3_2008 -begin - -builtin: hashing, diffie-hellman - -section{* Jeong, Katz, Lee : TS3 (2008) *} -/* - * Protocol: JKL-TS3-2008 - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" - * Jeong, Katz, Lee, 2008 - * Note: Although the paper title is the same as the 2004 - * original, the updated version from 2008 includes - * modified protocols and security models. - * - * Status: working - */ - -/* Protocol rules */ - -rule generate_ltk: - [ Fr(~lk) ] --> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] - -rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), - !Ephk(~ekI), - Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,'1','2','g'^~ekI ) > ) ] - -rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR), - In( < Y, h(('g'^~lkI)^~lkR,'2','1',Y )> ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - Y^~ekI ) ]-> - [ !Sessk( ~ekI, - Y^~ekI ) ] - -rule Resp_1: - [ In( < X, h( ('g'^~lkR)^~lkI,'1','2',X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - X^~ekR ) ]-> - [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,'2','1','g'^~ekR ) > ), - !Ephk(~ekR), - !Sessk( ~ekR, - X^~ekR ) ] - -rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -rule Ephk_reveal: - [ !Ephk(~ekI) ] - --[ EphkRev(~ekI) ]-> - [ Out(~ekI) ] - -rule Ltk_reveal: - [ !Ltk($A, k) ] - --[ LtkRev($A) ]-> - [ Out(k) ] - - -/* Security properties */ - -/* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" -*/ - - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" -/* - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_1_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not longterm-key-reveal */ - & (All #i3 a. LtkRev( a ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_initiator_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. */ - & (All #i3 #i4 tpartner kpartner. - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner kpartner. - (* (i1 < i3) | *) - SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) - )" - -/* An attack is valid in the security model if the session key of the test session is deduced and - the test session is clean. -*/ -lemma JKL2008_2_responder_key: - "not (Ex #i1 #i2 ttest I R k hkI hkR. - SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not ephemeral-key-reveal */ - & (All #i3 t. EphkRev( t ) @ i3 ==> F) - - /* Not session-key-reveal of test thread. */ - & (All #i3. SesskRev( ttest ) @ i3 ==> F) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & (All #i3 #i4 tpartner kpartner. - SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( tpartner ) @ i4 ==> F) - - /* If there is no partner thread, then there is no longterm-key-reveal for - the actor or intended partner. - (We model wpfs, for pfs, add i1 < i3 to conclusion) - */ - & (All #i3. LtkRev( I ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - & (All #i3. LtkRev( R ) @ i3 ==> - (Ex #i4 tpartner. - (* (i1 < i3) | *) - SidI_1( tpartner,I,R,hkI ) @i4)) - )" -*/ - -end diff --git a/data/examples/csf12/JKL_TS3_2008_KI_wPFS.spthy_nonterm b/data/examples/csf12/JKL_TS3_2008_KI_wPFS.spthy_nonterm new file mode 100644 --- /dev/null +++ b/data/examples/csf12/JKL_TS3_2008_KI_wPFS.spthy_nonterm @@ -0,0 +1,188 @@ +theory JKL_TS3_2008_KI_wPFS +begin + +builtin: hashing, diffie-hellman + +section{* Jeong, Katz, Lee : TS3 (2008) *} +/* + * Protocol: JKL-TS3-2008 + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange" + * Jeong, Katz, Lee, 2008 + * Note: Although the paper title is the same as the 2004 + * original, the updated version from 2008 includes + * modified protocols and security models. + * + * Status: working + */ + +/* Protocol rules */ + +rule generate_ltk: + [ Fr(~lk) ] --> + [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] + +rule Init_1: + [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ] + --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), + !Ephk(~ekI), + Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,'1','2','g'^~ekI ) > ) ] + +rule Init_2: + [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR), + In( < Y, h(('g'^~lkI)^~lkR,'2','1',Y )> ) ] + --[SidI_2( ~ekI, $I, $R, hkI, Y, + Y^~ekI ) ]-> + [ !Sessk( ~ekI, + Y^~ekI ) ] + +rule Resp_1: + [ In( < X, h( ('g'^~lkR)^~lkI,'1','2',X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] + --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , + X^~ekR ) ]-> + [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,'2','1','g'^~ekR ) > ), + !Ephk(~ekR), + !Sessk( ~ekR, + X^~ekR ) ] + +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ephk_reveal: + [ !Ephk(~ekI) ] + --[ EphkRev(~ekI) ]-> + [ Out(~ekI) ] + +rule Ltk_reveal: + [ !Ltk($A, k) ] + --[ LtkRev($A) ]-> + [ Out(k) ] + + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ + + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_1_initiator_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" +/* + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_1_responder_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not longterm-key-reveal */ + & (All #i3 a. LtkRev( a ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_2_initiator_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. */ + & (All #i3 #i4 tpartner kpartner. + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner kpartner. + (* (i1 < i3) | *) + SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4)) + )" + +/* An attack is valid in the security model if the session key of the test session is deduced and + the test session is clean. +*/ +lemma JKL2008_2_responder_key: + "not (Ex #i1 #i2 ttest I R k hkI hkR. + SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 + + /* Not ephemeral-key-reveal */ + & (All #i3 t. EphkRev( t ) @ i3 ==> F) + + /* Not session-key-reveal of test thread. */ + & (All #i3. SesskRev( ttest ) @ i3 ==> F) + + /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. + A session key reveal can only happen after SidI_2 is logged anyways. + */ + & (All #i3 #i4 tpartner kpartner. + SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3 + & SesskRev( tpartner ) @ i4 ==> F) + + /* If there is no partner thread, then there is no longterm-key-reveal for + the actor or intended partner. + (We model wpfs, for pfs, add i1 < i3 to conclusion) + */ + & (All #i3. LtkRev( I ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + & (All #i3. LtkRev( R ) @ i3 ==> + (Ex #i4 tpartner. + (* (i1 < i3) | *) + SidI_1( tpartner,I,R,hkI ) @i4)) + )" +*/ + +end diff --git a/data/examples/csf12/KAS1.spthy b/data/examples/csf12/KAS1.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/KAS1.spthy @@ -0,0 +1,129 @@ +theory KAS1 +begin + +builtins: hashing, asymmetric-encryption + +section{* KAS1 *} + +/* + * Protocol: KAS1 + * Modeler: Cas Cremers + * Date: April 2012 + * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol" + * Chatterjee, Menezes, Ustaoglu, 2011 + * Model: Weakened version of the model for the initiator only, + * motivated by the informal remarks for KAS1 security in the paper. + * + * Status: working + * + * Notes: Confirming the results from the paper, we find that we + * cannot allow: + * - compromise of the peer's long-term key + * - compromise of the test session's ephemeral key + * + * The model covers KCI and KI. + */ + +functions: KDF/1 +functions: MAC/2 + +/* Protocol rules */ + +/* Generate long-term keypair */ +rule Register_pk: + let pkA = pk(~ltkA) + in + [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ] + +/* Initiator */ +rule Init_K1_1: + let c1 = aenc{ ~m1 }pkR + in + [ Fr( ~m1 ), !Ltk( $I, ~lkI ), !Pk($R,pkR) ] + --[ SidI ( ~m1, $I, $R, <$I, $R, 'Init', c1>) ]-> + [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1), !Ephk( ~m1,~m1 ), Out( c1 ) ] + +rule Resp_K1_1: + let m1 = adec(c1, ~lkR) + nonceB = ~m2 + key = KDF(< m1, $I, $R, nonceB, c1 >) + tagB = MAC(key, (< 'KC_1_V', $R, $I, nonceB, c1 >) ) + in + [ Fr( ~m2 ), In( c1 ), !Ltk( $R, ~lkR ), !Pk($I,pkI) ] + --[ SidR ( ~m2, $R, $I, <$R, $I, 'Resp', nonceB, c1>) + , Match( ~m2, <$I, $R, 'Init', c1>) + , Match( ~m2, <$I, $R, 'Init', c1, nonceB>) + ]-> + [ Out(< nonceB , tagB >), !Sessk( ~m2, key ) ] + +rule Init_K1_2: + let m2 = adec(nonceB, ~lkI) + key = KDF(< ~m1, $I, $R, nonceB, c1 >) + tagB = MAC( key, (< 'KC_1_V', $R, $I, nonceB, c1 >) ) + in + [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1 ) , In(< nonceB, tagB >) ] + --[ SidI ( ~m1, $I, $R, <$I, $R, 'Init', c1, nonceB> ) + , Match( ~m1, <$R, $I, 'Resp', nonceB, c1> ) + , Accept( ~m1, $I, $R, key) + ]-> + [ !Sessk( ~m1, key ) ] + + + + +/* Key Reveals for the eCK model */ +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ltk_reveal: + [ !Ltk($A, lkA) ] + --[ LtkRev($A) ]-> + [ Out(lkA) ] + +rule Ephk_reveal: + [ !Ephk(~s, ~ek) ] + --[ EphkRev(~s) ]-> + [ Out(~ek) ] + + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ +lemma KAS1_key_secrecy: + "not (Ex #i1 #i2 s A B k . + Accept(s, A, B, k) @ i1 & K( k ) @ i2 + + /* No session-key-reveal of test thread. */ + & not(Ex #i4. SesskRev( s ) @ i4 ) + + /* No ephemeral key reveal of the test thread */ + & not(Ex #i4. EphkRev( s ) @ i4 ) + + /* If matching session exists (for all matching sessions...) */ + & (All ss #i4 #i5 C D ms. + ( SidR ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5) + ==> + ( not(Ex #i6 . SesskRev( ss ) @ i6 ) + & not(Ex #i6 . LtkRev ( B ) @ i6 ) + & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & LtkRev ( B ) @ i7 ) + ) + ) + + /* No matching session exists */ + & ( ( not(Ex ss #i4 #i5 C D ms. + SidR ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) ) + ==> + ( not(Ex #i6. LtkRev ( B ) @ i6 & i6 < i1 ) + ) + ) + )" + +end diff --git a/data/examples/csf12/KAS2_eCK.spthy b/data/examples/csf12/KAS2_eCK.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/KAS2_eCK.spthy @@ -0,0 +1,128 @@ +theory KAS2_eCK +begin + +builtins: hashing, asymmetric-encryption + +section{* KAS2 *} + +/* + * Protocol: KAS2 + * Modeler: Cas Cremers + * Date: April 2012 + * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol" + * Chatterjee, Menezes, Ustaoglu, 2011 + * Model: eCK + * + * Status: working + */ + +functions: KDF/1 +functions: MAC/2 + +/* Protocol rules */ + +/* Generate long-term keypair */ +rule Register_pk: + let pkA = pk(~ltkA) + in + [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ] + +/* Initiator */ +rule Init_1: + let c1 = aenc{ ~m1 }pkR + in + [ Fr( ~m1 ), !Ltk( $I, ~lkI ), !Pk($R,pkR) ] + --[ Sid( ~m1, $I, $R, <$I, $R, 'Init', c1>) ]-> + [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1), !Ephk( ~m1,~m1 ), Out( c1 ) ] + +rule Resp_1: + let m1 = adec(c1, ~lkR) + c2 = aenc{ ~m2 }pkI + key = KDF(< m1, ~m2, $I, $R, c1, c2 >) + tagR = MAC(key, (< 'Resp', $R, $I, c2, c1 >) ) + in + [ Fr( ~m2 ), In( c1 ), !Ltk( $R, ~lkR ), !Pk($I,pkI) ] + --[ Sid ( ~m2, $R, $I, <$R, $I, 'Resp', c2, c1>) + , Match( ~m2, <$I, $R, 'Init', c1>) + , Match( ~m2, <$I, $R, 'Init', c1, c2>) + ]-> + [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2 ), !Ephk( ~m2,~m2 ), Out(< c2 , tagR >) ] + +rule Init_2: + let m2 = adec(c2, ~lkI) + key = KDF(< ~m1, m2, $I, $R, c1, c2 >) + tagR = MAC( key, (< 'Resp', $R, $I, c2, c1 >) ) + tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) ) + in + [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1 ) , In(< c2, tagR >) ] + --[ Sid ( ~m1, $I, $R, <$I, $R, 'Init', c1, c2> ) + , Match( ~m1, <$R, $I, 'Resp', c2, c1> ) + , Accept( ~m1, $I, $R, key) + ]-> + [ Out( tagI ), !Sessk( ~m1, key ) ] + +rule Resp_2: + let + key = KDF(< m1, ~m2, $I, $R, c1, c2 >) + tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) ) + in + [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2), In( tagI ) ] + --[ Accept( ~m2, $R, $I, key) ]-> + [ !Sessk( ~m2, key ) ] + + + +/* Key Reveals for the eCK model */ +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ltk_reveal: + [ !Ltk($A, lkA) ] + --[ LtkRev($A) ]-> + [ Out(lkA) ] + +rule Ephk_reveal: + [ !Ephk(~s, ~ek) ] + --[ EphkRev(~s) ]-> + [ Out(~ek) ] + + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ +lemma eCK_key_secrecy: + "not (Ex #i1 #i2 s A B k . + Accept(s, A, B, k) @ i1 & K( k ) @ i2 + + /* No session-key-reveal of test thread. */ + & not(Ex #i4. SesskRev( s ) @ i4 ) + + /* If matching session exists (for all matching sessions...) */ + & (All ss #i4 #i5 C D ms. + ( Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5) + ==> + ( not(Ex #i6 . SesskRev( ss ) @ i6 ) + & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & EphkRev ( s ) @ i7 ) + & not(Ex #i6 #i7. LtkRev ( B ) @ i6 & EphkRev ( ss ) @ i7 ) + ) + ) + + /* No matching session exists */ + & ( ( not(Ex ss #i4 #i5 C D ms. + Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) ) + ==> + ( not(Ex #i6 . LtkRev (B) @ i6 ) + & not(Ex #i6 #i7. LtkRev (A) @ i6 & EphkRev ( s ) @ i7 ) + ) + ) + )" + +end diff --git a/data/examples/csf12/KAS2_original.spthy b/data/examples/csf12/KAS2_original.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/KAS2_original.spthy @@ -0,0 +1,131 @@ +theory KAS2_original +begin + +builtins: hashing, asymmetric-encryption + +section{* KAS2 *} + +/* + * Protocol: KAS2 + * Modeler: Cas Cremers + * Date: April 2012 + * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol" + * Chatterjee, Menezes, Ustaoglu, 2011 + * Model: Original model from the above paper + * (a restricted version of eCK) + * + * Status: working + */ + +functions: KDF/1 +functions: MAC/2 + +/* Protocol rules */ + +/* Generate long-term keypair */ +rule Register_pk: + let pkA = pk(~ltkA) + in + [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ] + +/* Initiator */ +rule Init_1: + let c1 = aenc{ ~m1 }pkR + in + [ Fr( ~m1 ), !Ltk( $I, ~lkI ), !Pk($R,pkR) ] + --[ Sid( ~m1, $I, $R, <$I, $R, 'Init', c1>) ]-> + [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1), !Ephk( ~m1,~m1 ), Out( c1 ) ] + +rule Resp_1: + let m1 = adec(c1, ~lkR) + c2 = aenc{ ~m2 }pkI + key = KDF(< m1, ~m2, $I, $R, c1, c2 >) + tagR = MAC(key, (< 'Resp', $R, $I, c2, c1 >) ) + in + [ Fr( ~m2 ), In( c1 ), !Ltk( $R, ~lkR ), !Pk($I,pkI) ] + --[ Sid ( ~m2, $R, $I, <$R, $I, 'Resp', c2, c1>) + , Match( ~m2, <$I, $R, 'Init', c1>) + , Match( ~m2, <$I, $R, 'Init', c1, c2>) + ]-> + [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2 ), !Ephk( ~m2,~m2 ), Out(< c2 , tagR >) ] + +rule Init_2: + let m2 = adec(c2, ~lkI) + key = KDF(< ~m1, m2, $I, $R, c1, c2 >) + tagR = MAC( key, (< 'Resp', $R, $I, c2, c1 >) ) + tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) ) + in + [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1 ) , In(< c2, tagR >) ] + --[ Sid ( ~m1, $I, $R, <$I, $R, 'Init', c1, c2> ) + , Match( ~m1, <$R, $I, 'Resp', c2, c1> ) + , Accept( ~m1, $I, $R, key) + ]-> + [ Out( tagI ), !Sessk( ~m1, key ) ] + +rule Resp_2: + let + key = KDF(< m1, ~m2, $I, $R, c1, c2 >) + tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) ) + in + [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2), In( tagI ) ] + --[ Accept( ~m2, $R, $I, key) ]-> + [ !Sessk( ~m2, key ) ] + + + +/* Key Reveals for the eCK model */ +rule Sessk_reveal: + [ !Sessk(~tid, k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +rule Ltk_reveal: + [ !Ltk($A, lkA) ] + --[ LtkRev($A) ]-> + [ Out(lkA) ] + +rule Ephk_reveal: + [ !Ephk(~s, ~ek) ] + --[ EphkRev(~s) ]-> + [ Out(~ek) ] + + +/* Security properties */ + +/* +lemma key_agreement_reachable: + "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. + SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +*/ +lemma KAS_key_secrecy: + "not (Ex #i1 #i2 s A B k . + Accept(s, A, B, k) @ i1 & K( k ) @ i2 + + /* No session-key-reveal of test thread. */ + & not(Ex #i4. SesskRev( s ) @ i4 ) + + /* If matching session exists (for all matching sessions...) */ + & (All ss #i4 #i5 C D ms. + ( Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5) + ==> + ( not(Ex #i6 . SesskRev( ss ) @ i6 ) + & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & EphkRev ( s ) @ i7 ) + & not(Ex #i6 #i7. LtkRev ( B ) @ i6 & EphkRev ( ss ) @ i7 ) + & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & LtkRev ( B ) @ i7 ) + & not(Ex #i6 #i7. EphkRev ( s ) @ i6 & EphkRev ( ss ) @ i7 ) + ) + ) + + /* No matching session exists */ + & ( ( not(Ex ss #i4 #i5 C D ms. + Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) ) + ==> + ( not(Ex #i6. EphkRev ( s ) @ i6 ) + & not(Ex #i6. LtkRev ( B ) @ i6 & i6 < i1 ) + ) + ) + )" + +end diff --git a/data/examples/csf12/KEA_plus_KI_KCI.spthy b/data/examples/csf12/KEA_plus_KI_KCI.spthy --- a/data/examples/csf12/KEA_plus_KI_KCI.spthy +++ b/data/examples/csf12/KEA_plus_KI_KCI.spthy @@ -1,13 +1,13 @@ -theory KEA_plus_KCI +theory KEA_plus_KI_KCI begin -builtin: hashing, diffie-hellman +builtins: hashing, diffie-hellman section{* KEA+ *} /* * Protocol: KEA+ * Modeler: Cas Cremers - * Date: January 2012 + * Date: January/April 2012 * Source: "Security Analysis of KEA Authenticated Key Exchange Protocol" * Lauter, Mityagin, 2006 * Property: KI, KCI @@ -18,33 +18,42 @@ /* Protocol rules */ rule generate_ltk: - [ Fr(~lk) ] + let pkA = 'g'^~lkA + in + [ Fr(~lkA) ] --[ RegKey($A) ]-> - [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] + [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ] rule Init_1: + let epkI = 'g'^~ekI + in [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), + --[ SidI_1(~ekI, $I, $R, epkI ) ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, epkI ), !Ephk(~ekI), - Out( 'g'^~ekI ) ] + Out( epkI ) ] rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( ) ) ]-> - [ !Sessk( ~ekI, - h( ) ) ] + let pkR = 'g'^~lkR + key = h( ) + in + [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R, pkR ) ] + --[SidI_2( ~ekI, $I, $R, hkI, Y, key ) ]-> + [ !Sessk( ~ekI, key ) ] rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ]-> + let pkI = 'g'^~lkI + epkR = 'g'^~ekR + key = h(< pkI^~ekR, X^~lkR, $I, $R >) + in + [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, pkI) ] + --[ SidR_1( ~ekR, $I, $R, X, epkR , key ) ]-> [ Out( 'g'^~ekR ), !Ephk(~ekR), - !Sessk( ~ekR, - h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ] + !Sessk( ~ekR, key) ] + + rule Sessk_reveal: [ !Sessk(~tid, k) ] diff --git a/data/examples/csf12/KEA_plus_KI_KCI_wPFS.spthy b/data/examples/csf12/KEA_plus_KI_KCI_wPFS.spthy --- a/data/examples/csf12/KEA_plus_KI_KCI_wPFS.spthy +++ b/data/examples/csf12/KEA_plus_KI_KCI_wPFS.spthy @@ -1,13 +1,13 @@ -theory KEA_plus_wPFS +theory KEA_plus_KI_KCI_wPFS begin -builtin: hashing, diffie-hellman +builtins: hashing, diffie-hellman section{* KEA+ *} /* * Protocol: KEA+ * Modeler: Cas Cremers - * Date: January 2012 + * Date: January/April 2012 * Source: "Security Analysis of KEA Authenticated Key Exchange Protocol" * Lauter, Mityagin, 2006 * Property: KI, KCI, wPFS @@ -22,28 +22,35 @@ [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] rule Init_1: + let epkI = 'g'^~ekI + in [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ), + --[ SidI_1(~ekI, $I, $R, epkI ) ]-> + [ Init_1( ~ekI, $I, $R, ~lkI, epkI ), !Ephk(~ekI), - Out( 'g'^~ekI ) ] + Out( epkI ) ] rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( ) ) ]-> - [ !Sessk( ~ekI, - h( ) ) ] + let pkR = 'g'^~lkR + key = h( ) + in + [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R, pkR ) ] + --[SidI_2( ~ekI, $I, $R, hkI, Y, key ) ]-> + [ !Sessk( ~ekI, key ) ] rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR , - h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ]-> + let pkI = 'g'^~lkI + epkR = 'g'^~ekR + key = h(< pkI^~ekR, X^~lkR, $I, $R >) + in + [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, pkI) ] + --[ SidR_1( ~ekR, $I, $R, X, epkR , key ) ]-> [ Out( 'g'^~ekR ), !Ephk(~ekR), - !Sessk( ~ekR, - h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ] + !Sessk( ~ekR, key) ] + + rule Sessk_reveal: [ !Sessk(~tid, k) ] diff --git a/data/examples/csf12/KEA_plus_eCK.spthy b/data/examples/csf12/KEA_plus_eCK.spthy --- a/data/examples/csf12/KEA_plus_eCK.spthy +++ b/data/examples/csf12/KEA_plus_eCK.spthy @@ -1,7 +1,7 @@ -theory KEA_plus_KCI_wPFS +theory KEA_plus_eCK begin -builtin: hashing, diffie-hellman +builtins: hashing, diffie-hellman section{* KEA+ *} /* diff --git a/data/examples/csf12/NAXOS_eCK.spthy b/data/examples/csf12/NAXOS_eCK.spthy --- a/data/examples/csf12/NAXOS_eCK.spthy +++ b/data/examples/csf12/NAXOS_eCK.spthy @@ -1,21 +1,24 @@ theory NAXOS_eCK begin -builtin: diffie-hellman, hashing +builtins: diffie-hellman section{* NAXOS *} /* * Protocol: NAXOS * Modeler: Cas Cremers, Benedikt Schmidt - * Date: January 2012 + * Date: January 2012/April 2012 * Source: "Stronger Security of Authenticated Key Exchange" * LaMacchia, Lauter, Mityagin, 2007 * Property: eCK security * - * Status: working + * Status: Working */ +functions: h1/1 +functions: h2/1 + /* Protocol rules */ /* In the description in the paper, we omitted the sorts. @@ -26,131 +29,125 @@ /* Generate long-term keypair */ rule generate_ltk: - [ Fr(~lkA) ] --> - [ !Ltk( $A, ~lkA ), !Pk( $A, 'g'^~lkA ), Out( 'g'^~lkA ) ] + let pkA = 'g'^~lkA + in + [ Fr(~lkA) ] + --[ RegKey($A) ]-> + [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ] /* Initiator */ -/* To formulate the responder property, we also define a SidI action for - * the first rule. For brevity, we omitted this from the description in - * the paper because there the responder property is not specified. */ - rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^h(< '1', ~ekI, ~lkI >)) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^h(< '1', ~ekI, ~lkI >) ), - !Ephk(~ekI), - Out( 'g'^h(< '1', ~ekI, ~lkI >) ) ] + let exI = h1(<~eskI, ~lkI >) + hkI = 'g'^exI + in + [ Fr( ~eskI ), !Ltk( $I, ~lkI ) ] + --> + [ Init_1( ~eskI, $I, $R, ~lkI, hkI ) + , !Ephk(~eskI, ~eskI) + , Out( hkI ) ] rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( < '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI>), Y^h(< '1', ~ekI, ~lkI>), $I, $R> ) ) ]-> - [ !Sessk( ~ekI, - h(< '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI> ), Y^h(< '1', ~ekI, ~lkI >), $I, $R>) ) ] + let pkR = 'g'^~lkR + exI = h1(< ~eskI, ~lkI >) + kI = h2(< Y^~lkI, pkR^exI, Y^exI, $I, $R >) + in + [ Init_1( ~eskI, $I, $R, ~lkI , hkI), !Pk( $R, pkR ), In( Y ) ] + --[ Accept( ~eskI, $I, $R, kI) + , Sid( ~eskI, < 'Init', $I, $R, hkI, Y >) + , Match( ~eskI, < 'Resp', $R, $I, hkI, Y >) + ]-> + [ !Sessk( ~eskI, kI) ] /* Responder */ rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^h( < '1', ~ekR, ~lkR > ), - h(< '2', ('g'^~lkI)^h(< '1', ~ekR, ~lkR >) ,X^~lkR, X^h(< '1', ~ekR, ~lkR >), $I, $R >) ) ]-> - [ Out( 'g'^h(<'1', ~ekR, ~lkR >) ), - !Ephk(~ekR), - !Sessk( ~ekR, - h(< '2', ('g'^~lkI)^h(<'1', ~ekR, ~lkR >) ,X^~lkR, X^h(<'1', ~ekR, ~lkR >), $I, $R >) ) ] + let pkI = 'g'^~lkI + exR = h1(< ~eskR, ~lkR >) + hkr = 'g'^exR + kR = h2(< pkI^exR, X^~lkR, X^exR, $I, $R >) + in + [ Fr( ~eskR ), !Ltk($R, ~lkR), !Pk($I, pkI), In( X ) ] + --[ Accept( ~eskR, $R, $I, kR ) + , Sid( ~eskR, <'Resp', $R, $I, X, hkr >) + , Match( ~eskR, <'Init', $I, $R, X, hkr> ) + ]-> + [ Out( hkr ), + !Ephk(~eskR, ~eskR), + !Sessk( ~eskR, kR) ] /* Key Reveals for the eCK model */ rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] + [ !Sessk(~tid, k) ] --[ SesskRev(~tid) ]-> [ Out(k) ] rule Ltk_reveal: - [ !Ltk($A, lkA) ] - --[ LtkRev($A) ]-> - [ Out(lkA) ] + [ !Ltk($A, lkA) ] --[ LtkRev($A) ]-> [ Out(lkA) ] rule Ephk_reveal: - [ !Ephk(~ekA) ] - --[ EphkRev(~ekA) ]-> - [ Out(~ekA) ] + [ !Ephk(~s, ~ek) ] --[ EphkRev(~s) ]-> [ Out(~ek) ] /* Security properties */ - /* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +lemma eCK_same_key: + " // If every agent registered at most one public key + (All A #i #j. RegKey(A)@i & RegKey(A)@j ==> (#i = #j)) + ==> // then matching sessions accept the same key + (not (Ex #i1 #i2 #i3 #i4 s ss k kk A B minfo . + Accept(s, A, B, k ) @ i1 + & Accept(ss, B, A, kk) @ i2 + & Sid(s, minfo) @ i3 + & Match(ss, minfo) @i4 + & not( k = kk ) + ) )" */ -/* An attack is valid in eCK if the session key of the test session is deduced and - the test session is clean. -*/ -lemma eCK_initiator_key: - "not (Ex #i1 #i2 ekI I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not both longterm-key-reveal _and_ ephemeral-key-reveal - * for test thread. */ - & not(Ex #i3 #i4. LtkRev( I ) @ i3 & EphkRev( ekI ) @ i4) - - /* No session-key-reveal of test thread. */ - & not(Ex #i3. SesskRev( ekI ) @ i3 ) - - /* No session-key-reveal for matching session. */ - & not(Ex #i3 #i4 ekR kpartner. - SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( ekR ) @ i4 ) - - /* Not both long-term-key-reveal and ephemeral-key-reveal - * for matching session */ - & not(Ex #i3 #i4 #i5 ekR kpartner. - SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3 - & LtkRev( R ) @ i4 - & EphkRev( ekR ) @ i5 ) - - /* Longterm-key-reveal of partner only if there is a - * matching session. */ - /* (We model eCK-wpfs, for eCK-pfs, add i1 < i3 to conclusion) */ - & (All #i3. LtkRev( R ) @ i3 ==> - (* (i1 < i3) | *) - (Ex #i4 ekR kpartner. - SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i4)))" - - -/* An attack is valid in eCK if the session key of the test session is deduced and - the test session is clean. -*/ -lemma eCK_responder_key: - "not (Ex #i1 #i2 ekR I R k hkI hkR. - SidR_1(ekR, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not longterm-key-reveal _and_ ephemeral-key-reveal of actor . */ - & not(Ex #i3 #i4. LtkRev( R ) @ i3 & EphkRev( ekR ) @ i4) - - /* Not session-key-reveal of test thread. */ - & not(Ex #i3. SesskRev( ekR ) @ i3 ) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & not(Ex #i3 #i4 ekI kpartner. - SidI_2( ekI,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( ekI ) @ i4 ) - - /* If there is a partner thread, then not long-term-key-reveal and ephemeral-key-reveal. */ - & not(Ex #i3 #i4 #i5 ekI. - SidI_1( ekI,I,R,hkI ) @i3 - & LtkRev( I ) @ i4 - & EphkRev( ekI ) @ i5 ) +lemma eCK_key_secrecy: + /* + * The property specification very closely follows the original eCK + * (ProvSec) paper: + * + * If there exists a Test session whose key k is known to the + * Adversary, then... + */ + "(All #i1 #i2 Test A B k. + Accept(Test, A, B, k) @ i1 & K( k ) @ i2 + ==> ( + /* ... the Test session must be "not clean". + * Test is not clean if one of the following has happened: + */ + /* 1a. session-key-reveal of test thread. */ + (Ex #i3. SesskRev( Test ) @ i3 ) - /* If there is no partner thread, then there is no longterm-key-reveal for - the intended partner. - (We model eCK-wpfs, for eCK-pfs, add i1 < i3 to conclusion) - */ - & (All #i3. LtkRev( I ) @ i3 ==> - (* (i1 < i3) | *) - (Ex #i4 ekI. - SidI_1( ekI,I,R,hkI ) @i4)))" + /* 1b. session-key-reveal of matching session */ + | (Ex MatchingSession #i3 #i4 ms. + /* ( MatchingSession's 'ms' info matches with Test ) */ + ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4) + & ( + (Ex #i5. SesskRev( MatchingSession ) @ i5 ) + ) + ) + /* 2. If matching session exists and ... */ + | (Ex MatchingSession #i3 #i4 ms. + /* ( MatchingSession's 'ms' info matches with Test ) */ + ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4) + & ( + /* 2a. reveal either both sk_A and esk_A, or */ + (Ex #i5 #i6. LtkRev ( A ) @ i5 & EphkRev ( Test ) @ i6 ) + /* 2b. both sk_B and esk_B */ + | (Ex #i5 #i6. LtkRev ( B ) @ i5 & EphkRev ( MatchingSession ) @ i6 ) + ) + ) + /* 3. No matching session exists and ... */ + | ( ( not(Ex MatchingSession #i3 #i4 ms. + /* ( MatchingSession's 'ms' info matches with Test ) */ + Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4 ) ) + & ( + /* 3a. reveal either sk_B, or */ + (Ex #i5 . LtkRev (B) @ i5 ) + /* 3b. both sk_A and esk_A */ + | (Ex #i5 #i6. LtkRev (A) @ i5 & EphkRev ( Test ) @ i6 ) + ) + ) + ) + )" end diff --git a/data/examples/csf12/NAXOS_eCK_PFS.spthy b/data/examples/csf12/NAXOS_eCK_PFS.spthy --- a/data/examples/csf12/NAXOS_eCK_PFS.spthy +++ b/data/examples/csf12/NAXOS_eCK_PFS.spthy @@ -1,20 +1,24 @@ theory NAXOS_eCK_PFS begin -builtin: diffie-hellman, hashing +builtins: diffie-hellman section{* NAXOS *} /* * Protocol: NAXOS * Modeler: Cas Cremers, Benedikt Schmidt - * Date: January 2012 + * Date: January 2012/April 2012 * Source: "Stronger Security of Authenticated Key Exchange" * LaMacchia, Lauter, Mityagin, 2007 + * Property: eCK security with PFS * - * Status: working + * Status: Working */ +functions: h1/1 +functions: h2/1 + /* Protocol rules */ /* In the description in the paper, we omitted the sorts. @@ -25,129 +29,125 @@ /* Generate long-term keypair */ rule generate_ltk: - [ Fr(~lkA) ] --> - [ !Ltk( $A, ~lkA ), !Pk( $A, 'g'^~lkA ), Out( 'g'^~lkA ) ] + let pkA = 'g'^~lkA + in + [ Fr(~lkA) ] + --[ RegKey($A) ]-> + [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ] /* Initiator */ -/* To formulate the responder property, we also define a SidI action for - * the first rule. For brevity, we omitted this from the description in - * the paper because there the responder property is not specified. */ - rule Init_1: - [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ] - --[ SidI_1(~ekI,$I,$R, 'g'^h(< '1', ~ekI, ~lkI >)) ]-> - [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^h(< '1', ~ekI, ~lkI >) ), - !Ephk(~ekI), - Out( 'g'^h(< '1', ~ekI, ~lkI >) ) ] + let exI = h1(<~eskI, ~lkI >) + hkI = 'g'^exI + in + [ Fr( ~eskI ), !Ltk( $I, ~lkI ) ] + --> + [ Init_1( ~eskI, $I, $R, ~lkI, hkI ) + , !Ephk(~eskI, ~eskI) + , Out( hkI ) ] rule Init_2: - [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ] - --[SidI_2( ~ekI, $I, $R, hkI, Y, - h( < '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI>), Y^h(< '1', ~ekI, ~lkI>), $I, $R> ) ) ]-> - [ !Sessk( ~ekI, - h(< '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI> ), Y^h(< '1', ~ekI, ~lkI >), $I, $R>) ) ] + let pkR = 'g'^~lkR + exI = h1(< ~eskI, ~lkI >) + kI = h2(< Y^~lkI, pkR^exI, Y^exI, $I, $R >) + in + [ Init_1( ~eskI, $I, $R, ~lkI , hkI), !Pk( $R, pkR ), In( Y ) ] + --[ Accept( ~eskI, $I, $R, kI) + , Sid( ~eskI, < 'Init', $I, $R, hkI, Y >) + , Match( ~eskI, < 'Resp', $R, $I, hkI, Y >) + ]-> + [ !Sessk( ~eskI, kI) ] /* Responder */ rule Resp_1: - [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ] - --[ SidR_1( ~ekR, $I, $R, X, 'g'^h( < '1', ~ekR, ~lkR > ), - h(< '2', ('g'^~lkI)^h(< '1', ~ekR, ~lkR >) ,X^~lkR, X^h(< '1', ~ekR, ~lkR >), $I, $R >) ) ]-> - [ Out( 'g'^h(<'1', ~ekR, ~lkR >) ), - !Ephk(~ekR), - !Sessk( ~ekR, - h(< '2', ('g'^~lkI)^h(<'1', ~ekR, ~lkR >) ,X^~lkR, X^h(<'1', ~ekR, ~lkR >), $I, $R >) ) ] + let pkI = 'g'^~lkI + exR = h1(< ~eskR, ~lkR >) + hkr = 'g'^exR + kR = h2(< pkI^exR, X^~lkR, X^exR, $I, $R >) + in + [ Fr( ~eskR ), !Ltk($R, ~lkR), !Pk($I, pkI), In( X ) ] + --[ Accept( ~eskR, $R, $I, kR ) + , Sid( ~eskR, <'Resp', $R, $I, X, hkr >) + , Match( ~eskR, <'Init', $I, $R, X, hkr> ) + ]-> + [ Out( hkr ), + !Ephk(~eskR, ~eskR), + !Sessk( ~eskR, kR) ] /* Key Reveals for the eCK model */ rule Sessk_reveal: - [ !Sessk(~tid, k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] + [ !Sessk(~tid, k) ] --[ SesskRev(~tid) ]-> [ Out(k) ] rule Ltk_reveal: - [ !Ltk($A, lkA) ] - --[ LtkRev($A) ]-> - [ Out(lkA) ] + [ !Ltk($A, lkA) ] --[ LtkRev($A) ]-> [ Out(lkA) ] rule Ephk_reveal: - [ !Ephk(~ekA) ] - --[ EphkRev(~ekA) ]-> - [ Out(~ekA) ] + [ !Ephk(~s, ~ek) ] --[ EphkRev(~s) ]-> [ Out(~ek) ] /* Security properties */ - /* -lemma key_agreement_reachable: - "not (Ex #i1 #i2 ekI ekR I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)" +lemma eCK_same_key: + " // If every agent registered at most one public key + (All A #i #j. RegKey(A)@i & RegKey(A)@j ==> (#i = #j)) + ==> // then matching sessions accept the same key + (not (Ex #i1 #i2 #i3 #i4 s ss k kk A B minfo . + Accept(s, A, B, k ) @ i1 + & Accept(ss, B, A, kk) @ i2 + & Sid(s, minfo) @ i3 + & Match(ss, minfo) @i4 + & not( k = kk ) + ) )" */ -/* An attack is valid in eCK if the session key of the test session is deduced and - the test session is clean. -*/ -lemma eCK_initiator_key: - "not (Ex #i1 #i2 ekI I R k hkI hkR. - SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not both longterm-key-reveal _and_ ephemeral-key-reveal - * for test thread. */ - & not(Ex #i3 #i4. LtkRev( I ) @ i3 & EphkRev( ekI ) @ i4) - - /* No session-key-reveal of test thread. */ - & not(Ex #i3. SesskRev( ekI ) @ i3 ) - - /* No session-key-reveal for matching session. */ - & not(Ex #i3 #i4 ekR kpartner. - SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( ekR ) @ i4 ) - - /* Not both long-term-key-reveal and ephemeral-key-reveal - * for matching session */ - & not(Ex #i3 #i4 #i5 ekR kpartner. - SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3 - & LtkRev( R ) @ i4 - & EphkRev( ekR ) @ i5 ) - - /* If there is a longterm key reveal, then it must occur after the initiator is finished - or there must be a matching session - */ - & (All #i3. LtkRev( R ) @ i3 ==> - (i1 < i3) - | (Ex #i4 ekR kpartner. - SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i4)))" - -/* An attack is valid in eCK if the session key of the test session is deduced and - the test session is clean. -*/ -lemma eCK_responder_key: - "not (Ex #i1 #i2 ekR I R k hkI hkR. - SidR_1(ekR, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2 - - /* Not longterm-key-reveal _and_ ephemeral-key-reveal of actor . */ - & not(Ex #i3 #i4. LtkRev( R ) @ i3 & EphkRev( ekR ) @ i4) - - /* Not session-key-reveal of test thread. */ - & not(Ex #i3. SesskRev( ekR ) @ i3 ) - - /* Not session-key-reveal of partner thread. Note that we use SidI_2 here. - A session key reveal can only happen after SidI_2 is logged anyways. - */ - & not(Ex #i3 #i4 ekI kpartner. - SidI_2( ekI,I,R,hkI,hkR,kpartner ) @i3 - & SesskRev( ekI ) @ i4 ) - - /* If there is a partner thread, then not long-term-key-reveal and ephemeral-key-reveal. */ - & not(Ex #i3 #i4 #i5 ekI. - SidI_1( ekI,I,R,hkI ) @i3 - & LtkRev( I ) @ i4 - & EphkRev( ekI ) @ i5 ) +lemma eCK_PFS_key_secrecy: + /* + * The property specification very closely follows the original eCK + * (ProvSec) paper: + * + * If there exists a Test session whose key k is known to the + * Adversary, then... + */ + "(All #i1 #i2 Test A B k. + Accept(Test, A, B, k) @ i1 & K( k ) @ i2 + ==> ( + /* ... the Test session must be "not clean". + * Test is not clean if one of the following has happened: + */ + /* 1a. session-key-reveal of test thread. */ + (Ex #i3. SesskRev( Test ) @ i3 ) - /* If there is a longterm key reveal, then it must occur after the responder is finished - or there must be a matching session. - */ - & (All #i3. LtkRev( I ) @ i3 ==> - (i1 < i3) - | (Ex #i4 ekI. - SidI_1( ekI,I,R,hkI ) @i4)))" + /* 1b. session-key-reveal of matching session */ + | (Ex MatchingSession #i3 #i4 ms. + /* ( MatchingSession's 'ms' info matches with Test ) */ + ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4) + & ( + (Ex #i5. SesskRev( MatchingSession ) @ i5 ) + ) + ) + /* 2. If matching session exists and ... */ + | (Ex MatchingSession #i3 #i4 ms. + /* ( MatchingSession's 'ms' info matches with Test ) */ + ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4) + & ( + /* 2a. reveal either both sk_A and esk_A, or */ + (Ex #i5 #i6. LtkRev ( A ) @ i5 & EphkRev ( Test ) @ i6 ) + /* 2b. both sk_B and esk_B */ + | (Ex #i5 #i6. LtkRev ( B ) @ i5 & EphkRev ( MatchingSession ) @ i6 ) + ) + ) + /* 3. No matching session exists and ... */ + | ( ( not(Ex MatchingSession #i3 #i4 ms. + /* ( MatchingSession's 'ms' info matches with Test ) */ + Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4 ) ) + & ( + /* 3a. reveal either sk_B, or */ + (Ex #i5 . LtkRev (B) @ i5 & i5 < i1 ) /* Perfect Forward Secrecy (PFS) modification */ + /* 3b. both sk_A and esk_A */ + | (Ex #i5 #i6. LtkRev (A) @ i5 & EphkRev ( Test ) @ i6 ) + ) + ) + ) + )" end diff --git a/data/examples/csf12/STS-MAC-fix1.spthy b/data/examples/csf12/STS-MAC-fix1.spthy deleted file mode 100644 --- a/data/examples/csf12/STS-MAC-fix1.spthy +++ /dev/null @@ -1,123 +0,0 @@ -theory STS_MAC_FIX1 -begin - -builtin: diffie-hellman, hashing, signing - -functions: mac/2 - -section{* The Station-To-Station Protocol (MAC version, fix UKS attack with proof-of-possession of exponent) *} - -/* - * Protocol: Station-To-Station, MAC variant: fix with CA Proof-of-Possession check - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol" - * Blake-Wilson, Simon and Menezes, Alfred - * PKC '99, Springer, 1999 - * - * Status: working - */ - -// Public key infrastructure -/** - * The !Pk facts can be regarded as certificates - */ -rule Register_pk_normal: - [ Fr(~ltk) ] - --> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ] - -// Can register a key, but only if we know the exponent -// Models proof-of-possession check. -rule Register_pk_evil: - [ In(ltk) ] - --[ Corrupt($E) ]-> - [ !Ltk($E, ltk), !Pk($E, pk(ltk)), Out(pk(ltk)) ] - -// Protocol -rule Init_1: - [ Fr(~ekI), !Ltk($I, ~ltkI) ] - --> - [ Init_1( $I, $R, ~ltkI, ~ekI ) - , Out( <$I, $R, 'g' ^ ~ekI> ) ] - -rule Init_2: - [ Init_1( $I, $R, ~ltkI, ~ekI ) - , !Pk($R, pk(~ltkR)) - , In( <$R, $I, Y, - sign{ Y, 'g'^~ekI }~ltkR, - mac(Y^~ekI, - sign{ Y, 'g'^~ekI }~ltkR - ) - > ) ] - --[ AcceptedI(~ekI,$I,$R,'g'^~ekI,Y, h(Y ^ ~ekI)) ]-> - [ Out( <$I, $R, - sign{ 'g' ^ ~ekI, Y }~ltkI, - mac( Y^~ekI, - sign{ 'g' ^ ~ekI, Y }~ltkI - ) - > ), - !SessionKey(~ekI,$I,$R, h(Y ^ ~ekI)) - ] - -rule Resp_1: - [ !Ltk($R, ~ltkR) - , Fr(~ekR) - , In( <$I, $R, X > ) ] - --> - [ Resp_1( $I, $R, ~ltkR, ~ekR, X ) - , Out( <$R, $I, 'g' ^ ~ekR, - sign{ 'g' ^ ~ekR, X }~ltkR, - mac( X^~ekR, - sign{ 'g' ^ ~ekR, X }~ltkR - ) - > ) ] - -rule Resp_2: - [ !Pk($I, pk(~ltkI)) - , Resp_1( $I, $R, ~ltkR, ~ekR, X ) - , In( <$I, $R, - sign{ X, 'g'^~ekR }~ltkI, - mac(X^~ekR, - sign{ X, 'g'^~ekR }~ltkI - ) - > ) ] - --[ AcceptedR(~ekR,$I,$R,X,'g'^~ekR, h(X ^ ~ekR)) ]-> - [ !SessionKey(~ekR,$I,$R, h(X ^ ~ekR) ) ] - -rule Sessionkey_Reveal: - [ !SessionKey(~tid, $I,$R,k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -lemma KI_Perfect_Forward_Secrecy_I: - "not (Ex ttest I R sessKey #i1 #k hki hkr. - AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 & - not (Ex #r. Corrupt(I) @ r) & - not (Ex #r. Corrupt(R) @ r) & - K(sessKey) @ k & - // No session key reveal of test - not (Ex #i3. SesskRev(ttest) @ i3) & - // No session key reveal of partner - not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 - & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4 - ) - ) - " - -lemma KI_Perfect_Forward_Secrecy_R: - "not (Ex ttest I R sessKey #i1 #k hki hkr. - AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 & - not (Ex #r. Corrupt(I) @ r) & - not (Ex #r. Corrupt(R) @ r) & - K(sessKey) @ k & - // No session key reveal of test - not (Ex #i2. SesskRev(ttest) @ i2) & - // No session key reveal of partner - not (Ex #i2 #i3 tpartner kpartner. SesskRev(tpartner) @ i2 - & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i3 - ) - ) - " - -end diff --git a/data/examples/csf12/STS-MAC-fix2.spthy b/data/examples/csf12/STS-MAC-fix2.spthy deleted file mode 100644 --- a/data/examples/csf12/STS-MAC-fix2.spthy +++ /dev/null @@ -1,122 +0,0 @@ -theory STS_MAC_FIX2 -begin - -builtin: diffie-hellman, hashing, signing - -functions: mac/2 - -section{* The Station-To-Station Protocol (MAC version, fixed with names and tags) *} - -/* - * Protocol: Station-To-Station, MAC variant: fix with names and tags inside signatures - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol" - * Blake-Wilson, Simon and Menezes, Alfred - * PKC '99, Springer, 1999 - * - * Status: working - */ - -// Public key infrastructure -/** - * The !Pk facts can be regarded as certificates - * - * Here we model that the adversary might (and in fact always does) - * re-registers the public keys as his own, i.e., he claims a copy of - * the public key for the corrupt name E. - */ -rule Register_pk_clone: - [ Fr(~ltk) ] - --[ LtkSet($A, ~ltk), Corrupt($E) ]-> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ] - -// Protocol -rule Init_1: - [ Fr(~ekI), !Ltk($I, ~ltkI) ] - --> - [ Init_1( $I, $R, ~ltkI, ~ekI ) - , Out( <$I, $R, 'g' ^ ~ekI> ) ] - -rule Init_2: - [ Init_1( $I, $R, ~ltkI, ~ekI ) - , !Pk($R, pk(~ltkR)) - , In( <$R, $I, Y, - sign{ '1', $I, $R, Y, 'g'^~ekI }~ltkR, - mac(Y^~ekI, - sign{ '1', $I, $R, Y, 'g'^~ekI }~ltkR - ) - > ) ] - --[ AcceptedI(~ekI,$I,$R,'g'^~ekI,Y, h(Y ^ ~ekI) ) ]-> - [ Out( <$I, $R, - sign{ '2', $I, $R, 'g' ^ ~ekI, Y }~ltkI, - mac( Y^~ekI, - sign{ '2', $I, $R, 'g' ^ ~ekI, Y }~ltkI - ) - > ), - !SessionKey(~ekI,$I,$R, h(Y ^ ~ekI)) - ] - -rule Resp_1: - [ !Ltk($R, ~ltkR) - , Fr(~ekR) - , In( <$I, $R, X > ) ] - --> - [ Resp_1( $I, $R, ~ltkR, ~ekR, X ) - , Out( <$R, $I, 'g' ^ ~ekR, - sign{ '1', $I, $R, 'g' ^ ~ekR, X }~ltkR, - mac( X^~ekR, - sign{ '1', $I, $R, 'g' ^ ~ekR, X }~ltkR - ) - > ) ] - -rule Resp_2: - [ !Pk($I, pk(~ltkI)) - , Resp_1( $I, $R, ~ltkR, ~ekR, X ) - , In( <$I, $R, - sign{ '2', $I, $R, X, 'g'^~ekR }~ltkI, - mac(X^~ekR, - sign{ '2', $I, $R, X, 'g'^~ekR }~ltkI - ) - > ) ] - --[ AcceptedR(~ekR,$I,$R,X,'g'^~ekR, h(X ^ ~ekR) ) ]-> - [ !SessionKey(~ekR,$I,$R, h(X ^ ~ekR) ) ] - -rule Sessionkey_Reveal: - [ !SessionKey(~tid, $I,$R,k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -lemma KI_Perfect_Forward_Secrecy_I: - "not (Ex ttest I R sessKey #i1 #k hki hkr. - AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 & - not (Ex #r. Corrupt(I) @ r) & - not (Ex #r. Corrupt(R) @ r) & - K(sessKey) @ k & - // No session key reveal of test - not (Ex #i3. SesskRev(ttest) @ i3) & - // No session key reveal of partner - not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 - & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4 - ) - ) - " - -lemma KI_Perfect_Forward_Secrecy_R: - "not (Ex ttest I R sessKey #i1 #k hki hkr. - AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 & - not (Ex #r. Corrupt(I) @ r) & - not (Ex #r. Corrupt(R) @ r) & - K(sessKey) @ k & - // No session key reveal of test - not (Ex #i3. SesskRev(ttest) @ i3) & - // No session key reveal of partner - not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 - & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4 - ) - ) - " - - - -end diff --git a/data/examples/csf12/STS-MAC.spthy b/data/examples/csf12/STS-MAC.spthy deleted file mode 100644 --- a/data/examples/csf12/STS-MAC.spthy +++ /dev/null @@ -1,122 +0,0 @@ -theory STS_MAC -begin - -builtin: diffie-hellman, hashing, signing - -functions: mac/2 - -section{* The Station-To-Station Protocol (MAC version) *} - -/* - * Protocol: Station-To-Station, MAC variant - * Modeler: Cas Cremers - * Date: January 2012 - * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol" - * Blake-Wilson, Simon and Menezes, Alfred - * PKC '99, Springer, 1999 - * - * Status: working - */ - -// Public key infrastructure -/** - * The !Pk facts can be regarded as certificates - * - * Here we model that the adversary might (and in fact always does) - * re-registers the public keys as his own, i.e., he claims a copy of - * the public key for the corrupt name E. - */ -rule Register_pk_clone: - [ Fr(~ltk) ] - --[ LtkSet($A, ~ltk), Corrupt($E) ]-> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ] - -// Protocol -rule Init_1: - [ Fr(~ekI), !Ltk($I, ~ltkI) ] - --> - [ Init_1( $I, $R, ~ltkI, ~ekI ) - , Out( <$I, $R, 'g' ^ ~ekI> ) ] - -rule Init_2: - [ Init_1( $I, $R, ~ltkI, ~ekI ) - , !Pk($R, pk(~ltkR)) - , In( <$R, $I, Y, - sign{ Y, 'g'^~ekI }~ltkR, - mac(Y^~ekI, - sign{ Y, 'g'^~ekI }~ltkR - ) - > ) ] - --[ AcceptedI(~ekI,$I,$R,'g'^~ekI,Y, h(Y ^ ~ekI) ) ]-> - [ Out( <$I, $R, - sign{ 'g' ^ ~ekI, Y }~ltkI, - mac( Y^~ekI, - sign{ 'g' ^ ~ekI, Y }~ltkI - ) - > ), - !SessionKey(~ekI,$I,$R, h(Y ^ ~ekI)) - ] - -rule Resp_1: - [ !Ltk($R, ~ltkR) - , Fr(~ekR) - , In( <$I, $R, X > ) ] - --> - [ Resp_1( $I, $R, ~ltkR, ~ekR, X ) - , Out( <$R, $I, 'g' ^ ~ekR, - sign{ 'g' ^ ~ekR, X }~ltkR, - mac( X^~ekR, - sign{ 'g' ^ ~ekR, X }~ltkR - ) - > ) ] - -rule Resp_2: - [ !Pk($I, pk(~ltkI)) - , Resp_1( $I, $R, ~ltkR, ~ekR, X ) - , In( <$I, $R, - sign{ X, 'g'^~ekR }~ltkI, - mac(X^~ekR, - sign{ X, 'g'^~ekR }~ltkI - ) - > ) ] - --[ AcceptedR(~ekR,$I,$R,X,'g'^~ekR, h(X ^ ~ekR) ) ]-> - [ !SessionKey(~ekR,$I,$R, h(X ^ ~ekR) ) ] - -rule Sessionkey_Reveal: - [ !SessionKey(~tid, $I,$R,k) ] - --[ SesskRev(~tid) ]-> - [ Out(k) ] - -lemma KI_Perfect_Forward_Secrecy_I: - "not (Ex ttest I R sessKey #i1 #k hki hkr. - AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 & - not (Ex #r. Corrupt(I) @ r) & - not (Ex #r. Corrupt(R) @ r) & - K(sessKey) @ k & - // No session key reveal of test - not (Ex #i3. SesskRev(ttest) @ i3) & - // No session key reveal of partner - not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 - & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4 - ) - ) - " - -lemma KI_Perfect_Forward_Secrecy_R: - "not (Ex ttest I R sessKey #i1 #k hki hkr. - AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 & - not (Ex #r. Corrupt(I) @ r) & - not (Ex #r. Corrupt(R) @ r) & - K(sessKey) @ k & - // No session key reveal of test - not (Ex #i3. SesskRev(ttest) @ i3) & - // No session key reveal of partner - not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 - & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4 - ) - ) - " - - - -end diff --git a/data/examples/csf12/STS_MAC.spthy b/data/examples/csf12/STS_MAC.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/STS_MAC.spthy @@ -0,0 +1,129 @@ +theory STS_MAC +begin + +builtins: diffie-hellman, hashing, signing + +functions: mac/2 +functions: KDF/1 + +section{* The Station-To-Station Protocol (MAC version) *} + +/* + * Protocol: Station-To-Station, MAC variant + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol" + * Blake-Wilson, Simon and Menezes, Alfred + * PKC '99, Springer, 1999 + * + * Status: working + */ + +// Public key infrastructure +/** + * The !Pk facts can be regarded as certificates + * + * Here we model that the adversary might (and in fact always does) + * re-registers the public keys as his own, i.e., he claims a copy of + * the public key for the corrupt name E. + */ +rule Register_pk_clone: + [ Fr(~ltk) ] + --[ LtkSet($A, ~ltk), Corrupt($E) ]-> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ] + +// Protocol +rule Init_1: + let epkI = 'g'^~ekI + in + [ Fr(~ekI), !Ltk($I, ~ltkI) ] + --> + [ Init_1( $I, $R, ~ltkI, ~ekI ) + , Out( <$I, $R, epkI> ) ] + +rule Init_2: + let epkI = 'g'^~ekI + sigI = sign{ epkI, Y }~ltkI + sigR = sign{ Y, epkI }~ltkR + keymat = Y^~ekI + key = KDF(keymat) + in + [ Init_1( $I, $R, ~ltkI, ~ekI ) + , !Pk($R, pk(~ltkR)) + , In( <$R, $I, Y, sigR, mac( keymat, sigR) + > ) ] + --[ AcceptedI(~ekI,$I,$R,epkI,Y, key) ]-> + [ Out( <$I, $R, sigI, mac( keymat, sigI) > ), + !SessionKey(~ekI,$I,$R, key) + ] + +rule Resp_1: + let epkR = 'g'^~ekR + sigI = sign{ X, epkR }~ltkI + sigR = sign{ epkR, X }~ltkR + keymat = X^~ekR + key = KDF(keymat) + in + [ !Ltk($R, ~ltkR) + , Fr(~ekR) + , In( <$I, $R, X > ) ] + --> + [ Resp_1( $I, $R, ~ltkR, ~ekR, X ) + , Out(< $R, $I, epkR, sigR, mac( keymat, sigR ) >) + ] + + +rule Resp_2: + let epkR = 'g'^~ekR + sigI = sign{ X, epkR }~ltkI + sigR = sign{ epkR, X }~ltkR + keymat = X^~ekR + key = KDF(keymat) + in + [ !Pk($I, pk(~ltkI)) + , Resp_1( $I, $R, ~ltkR, ~ekR, X ) + , In( <$I, $R, sigI, mac( keymat, sigI ) >) + ] + --[ AcceptedR(~ekR,$I,$R,X,epkR, key ) ]-> + [ !SessionKey(~ekR,$I,$R, key) ] + + + +rule Sessionkey_Reveal: + [ !SessionKey(~tid, $I,$R,k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +lemma KI_Perfect_Forward_Secrecy_I: + "not (Ex ttest I R sessKey #i1 #k hki hkr. + AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 & + not (Ex #r. Corrupt(I) @ r) & + not (Ex #r. Corrupt(R) @ r) & + K(sessKey) @ k & + // No session key reveal of test + not (Ex #i3. SesskRev(ttest) @ i3) & + // No session key reveal of partner + not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 + & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4 + ) + ) + " + +lemma KI_Perfect_Forward_Secrecy_R: + "not (Ex ttest I R sessKey #i1 #k hki hkr. + AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 & + not (Ex #r. Corrupt(I) @ r) & + not (Ex #r. Corrupt(R) @ r) & + K(sessKey) @ k & + // No session key reveal of test + not (Ex #i3. SesskRev(ttest) @ i3) & + // No session key reveal of partner + not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 + & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4 + ) + ) + " + + + +end diff --git a/data/examples/csf12/STS_MAC_fix1.spthy b/data/examples/csf12/STS_MAC_fix1.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/STS_MAC_fix1.spthy @@ -0,0 +1,132 @@ +theory STS_MAC_fix1 +begin + +builtins: diffie-hellman, signing + +functions: mac/2 +functions: KDF/1 + +section{* The Station-To-Station Protocol (MAC version, fix UKS attack with proof-of-possession of exponent) *} + +/* + * Protocol: Station-To-Station, MAC variant: fix with CA Proof-of-Possession check + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol" + * Blake-Wilson, Simon and Menezes, Alfred + * PKC '99, Springer, 1999 + * + * Status: working + */ + +// Public keymat infrastructure +/** + * The !Pk facts can be regarded as certificates + */ +rule Register_pk_normal: + [ Fr(~ltk) ] + --> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ] + +// Can register a key, but only if we know the exponent +// Models proof-of-possession check. +rule Register_pk_evil: + [ In(ltk) ] + --[ Corrupt($E) ]-> + [ !Ltk($E, ltk), !Pk($E, pk(ltk)), Out(pk(ltk)) ] + +// Protocol +rule Init_1: + let epkI = 'g'^~ekI + in + [ Fr(~ekI), !Ltk($I, ~ltkI) ] + --> + [ Init_1( $I, $R, ~ltkI, ~ekI ) + , Out( <$I, $R, epkI> ) ] + +rule Init_2: + let epkI = 'g'^~ekI + sigI = sign{ epkI, Y }~ltkI + sigR = sign{ Y, epkI }~ltkR + keymat = Y^~ekI + key = KDF(keymat) + in + [ Init_1( $I, $R, ~ltkI, ~ekI ) + , !Pk($R, pk(~ltkR)) + , In( <$R, $I, Y, sigR, mac( keymat, sigR) + > ) ] + --[ AcceptedI(~ekI,$I,$R,epkI,Y, key) ]-> + [ Out( <$I, $R, sigI, mac( keymat, sigI) > ), + !SessionKey(~ekI,$I,$R, key) + ] + +rule Resp_1: + let epkR = 'g'^~ekR + sigI = sign{ X, epkR }~ltkI + sigR = sign{ epkR, X }~ltkR + keymat = X^~ekR + key = KDF(keymat) + in + [ !Ltk($R, ~ltkR) + , Fr(~ekR) + , In( <$I, $R, X > ) ] + --> + [ Resp_1( $I, $R, ~ltkR, ~ekR, X ) + , Out(< $R, $I, epkR, sigR, mac( keymat, sigR ) >) + ] + + +rule Resp_2: + let epkR = 'g'^~ekR + sigI = sign{ X, epkR }~ltkI + sigR = sign{ epkR, X }~ltkR + keymat = X^~ekR + key = KDF(keymat) + in + [ !Pk($I, pk(~ltkI)) + , Resp_1( $I, $R, ~ltkR, ~ekR, X ) + , In( <$I, $R, sigI, mac( keymat, sigI ) >) + ] + --[ AcceptedR(~ekR,$I,$R,X,epkR, key ) ]-> + [ !SessionKey(~ekR,$I,$R, key) ] + + + +rule Sessionkey_Reveal: + [ !SessionKey(~tid, $I,$R,k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + + + +lemma KI_Perfect_Forward_Secrecy_I: + "not (Ex ttest I R sessKey #i1 #k hki hkr. + AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 & + not (Ex #r. Corrupt(I) @ r) & + not (Ex #r. Corrupt(R) @ r) & + K(sessKey) @ k & + // No session keymat reveal of test + not (Ex #i3. SesskRev(ttest) @ i3) & + // No session keymat reveal of partner + not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 + & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4 + ) + ) + " + +lemma KI_Perfect_Forward_Secrecy_R: + "not (Ex ttest I R sessKey #i1 #k hki hkr. + AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 & + not (Ex #r. Corrupt(I) @ r) & + not (Ex #r. Corrupt(R) @ r) & + K(sessKey) @ k & + // No session keymat reveal of test + not (Ex #i2. SesskRev(ttest) @ i2) & + // No session keymat reveal of partner + not (Ex #i2 #i3 tpartner kpartner. SesskRev(tpartner) @ i2 + & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i3 + ) + ) + " + +end diff --git a/data/examples/csf12/STS_MAC_fix2.spthy b/data/examples/csf12/STS_MAC_fix2.spthy new file mode 100644 --- /dev/null +++ b/data/examples/csf12/STS_MAC_fix2.spthy @@ -0,0 +1,129 @@ +theory STS_MAC_fix2 +begin + +builtins: diffie-hellman, hashing, signing + +functions: mac/2 +functions: KDF/1 + +section{* The Station-To-Station Protocol (MAC version, fixed with names and tags) *} + +/* + * Protocol: Station-To-Station, MAC variant: fix with names and tags inside signatures + * Modeler: Cas Cremers + * Date: January 2012 + * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol" + * Blake-Wilson, Simon and Menezes, Alfred + * PKC '99, Springer, 1999 + * + * Status: working + */ + +// Public key infrastructure +/** + * The !Pk facts can be regarded as certificates + * + * Here we model that the adversary might (and in fact always does) + * re-registers the public keys as his own, i.e., he claims a copy of + * the public key for the corrupt name E. + */ +rule Register_pk_clone: + [ Fr(~ltk) ] + --[ LtkSet($A, ~ltk), Corrupt($E) ]-> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ] + +// Protocol +rule Init_1: + let epkI = 'g'^~ekI + in + [ Fr(~ekI), !Ltk($I, ~ltkI) ] + --> + [ Init_1( $I, $R, ~ltkI, ~ekI ) + , Out( <$I, $R, epkI> ) ] + +rule Init_2: + let epkI = 'g'^~ekI + sigI = sign{ '2', $I, $R, epkI, Y }~ltkI + sigR = sign{ '1', $I, $R, Y, epkI }~ltkR + keymat = Y^~ekI + key = KDF(keymat) + in + [ Init_1( $I, $R, ~ltkI, ~ekI ) + , !Pk($R, pk(~ltkR)) + , In( <$R, $I, Y, sigR, mac( keymat, sigR) + > ) ] + --[ AcceptedI(~ekI,$I,$R,epkI,Y, key) ]-> + [ Out( <$I, $R, sigI, mac( keymat, sigI) > ), + !SessionKey(~ekI,$I,$R, key) + ] + +rule Resp_1: + let epkR = 'g'^~ekR + sigI = sign{ '2', $I, $R, X, epkR }~ltkI + sigR = sign{ '1', $I, $R, epkR, X }~ltkR + keymat = X^~ekR + key = KDF(keymat) + in + [ !Ltk($R, ~ltkR) + , Fr(~ekR) + , In( <$I, $R, X > ) ] + --> + [ Resp_1( $I, $R, ~ltkR, ~ekR, X ) + , Out(< $R, $I, epkR, sigR, mac( keymat, sigR ) >) + ] + + +rule Resp_2: + let epkR = 'g'^~ekR + sigI = sign{ '2', $I, $R, X, epkR }~ltkI + sigR = sign{ '1', $I, $R, epkR, X }~ltkR + keymat = X^~ekR + key = KDF(keymat) + in + [ !Pk($I, pk(~ltkI)) + , Resp_1( $I, $R, ~ltkR, ~ekR, X ) + , In( <$I, $R, sigI, mac( keymat, sigI ) >) + ] + --[ AcceptedR(~ekR,$I,$R,X,epkR, key ) ]-> + [ !SessionKey(~ekR,$I,$R, key) ] + + + +rule Sessionkey_Reveal: + [ !SessionKey(~tid, $I,$R,k) ] + --[ SesskRev(~tid) ]-> + [ Out(k) ] + +lemma KI_Perfect_Forward_Secrecy_I: + "not (Ex ttest I R sessKey #i1 #k hki hkr. + AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 & + not (Ex #r. Corrupt(I) @ r) & + not (Ex #r. Corrupt(R) @ r) & + K(sessKey) @ k & + // No session key reveal of test + not (Ex #i3. SesskRev(ttest) @ i3) & + // No session key reveal of partner + not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 + & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4 + ) + ) + " + +lemma KI_Perfect_Forward_Secrecy_R: + "not (Ex ttest I R sessKey #i1 #k hki hkr. + AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 & + not (Ex #r. Corrupt(I) @ r) & + not (Ex #r. Corrupt(R) @ r) & + K(sessKey) @ k & + // No session key reveal of test + not (Ex #i3. SesskRev(ttest) @ i3) & + // No session key reveal of partner + not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3 + & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4 + ) + ) + " + + + +end diff --git a/data/examples/csf12/SignedDH_PFS.spthy b/data/examples/csf12/SignedDH_PFS.spthy --- a/data/examples/csf12/SignedDH_PFS.spthy +++ b/data/examples/csf12/SignedDH_PFS.spthy @@ -1,4 +1,4 @@ -theory SignedDH +theory SignedDH_PFS begin section{* The Signed Diffie-Hellman Protocol *} @@ -11,7 +11,7 @@ * Status: working */ -builtin: diffie-hellman, signing +builtins: diffie-hellman, signing // Public key infrastructure rule Register_pk: diff --git a/data/examples/csf12/SignedDH_eCK.spthy b/data/examples/csf12/SignedDH_eCK.spthy --- a/data/examples/csf12/SignedDH_eCK.spthy +++ b/data/examples/csf12/SignedDH_eCK.spthy @@ -1,7 +1,7 @@ theory SignedDH_eCK begin -builtin: diffie-hellman, signing +builtins: diffie-hellman, signing section{* The Signed Diffie-Hellman Protocol in the eCK model *} diff --git a/data/examples/csf12/UM_PFS.spthy b/data/examples/csf12/UM_PFS.spthy --- a/data/examples/csf12/UM_PFS.spthy +++ b/data/examples/csf12/UM_PFS.spthy @@ -1,7 +1,7 @@ theory UM_PFS begin -builtin: hashing, diffie-hellman +builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *} diff --git a/data/examples/csf12/UM_eCK.spthy b/data/examples/csf12/UM_eCK.spthy --- a/data/examples/csf12/UM_eCK.spthy +++ b/data/examples/csf12/UM_eCK.spthy @@ -1,7 +1,7 @@ theory UM_eCK begin -builtin: hashing, diffie-hellman +builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *} diff --git a/data/examples/csf12/UM_eCK_noKCI.spthy b/data/examples/csf12/UM_eCK_noKCI.spthy --- a/data/examples/csf12/UM_eCK_noKCI.spthy +++ b/data/examples/csf12/UM_eCK_noKCI.spthy @@ -1,7 +1,7 @@ theory UM_eCK_noKCI begin -builtin: hashing, diffie-hellman +builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *} diff --git a/data/examples/csf12/UM_wPFS.spthy b/data/examples/csf12/UM_wPFS.spthy --- a/data/examples/csf12/UM_wPFS.spthy +++ b/data/examples/csf12/UM_wPFS.spthy @@ -1,7 +1,7 @@ theory UM_wPFS begin -builtin: hashing, diffie-hellman +builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *} diff --git a/data/examples/stable/InvariantsExample.spthy b/data/examples/stable/InvariantsExample.spthy new file mode 100644 --- /dev/null +++ b/data/examples/stable/InvariantsExample.spthy @@ -0,0 +1,69 @@ +theory InvariantsExample +begin + +builtins: symmetric-encryption + +/* + * Protocol: Minimal example of handle-based crypto + * Modeler: Simon Meier + * Date: April 2012 + * + * Status: working + + This example demonstrates the verification problem that we face when + reasoning about handle-based cryptography. The protocol is simple. It models + a crypto coprocessor that can generate new keys, use them to encrypt data, + and wrap keys with other stored keys. + + */ + + +/* Generate a fresh handle and a fresh key, store their association, and + * output the handle */ +rule NewKey: + [ Fr(~h), Fr(~k) ] + --[ NewKey(~h,~k) ]-> + [ !Store(~h,~k) , Out(~h) ] + +/* Encrypt a message using a key referenced by a handle */ +rule EncryptMsg: + [ !Store(h,k), In()] + --> + [ Out( senc{m}k ) ] + +/* Wrap a key reference by a handle using another key referenced by a second + * handle */ +rule WrapKey: + [ !Store(h1,k1), !Store(h2,k2), In()] + --> + [ Out( senc{k1}k2 ) ] + + +/* The 'reuse' attribute marks this property such that it should be used in + * proof of later theorems. This is what we'd like to do with such a property + * which proves that no created key can be deduced by the adversary. The + * 'invariant' attribute denotes that this property is an inductive invariant + * of normal dependency graphs. This instructs Tamarin to use induction as the + * first proof step. + * + * Note that construction of using 'Ded'-facts to log the conclusions of + * construction rules is work in progress. Tamarin is missing some constraint + * reduction rules to infer the presence of 'Ded'-facts in all cases. + * Moreover, it might also miss some rules to deal with the 'Last(i)' atoms, + * which states that 'i' is the last index in the trace that is annotated with + * an action. + * + * Tamarin can prove this property automatically. + */ +lemma NewKey_invariant [reuse, invariant]: + "not(Ex #i #j h k. NewKey(h, k) @ i & Ded(k) @ j) " + +/* This property talks only about standard traces that do not refer to the + * actions of construction rules. It can be proven thanks to the + * NewKey_invariant proven before. Try an interactive proof after removing the + * 'reuse' flag above to see what goes wrong without induction and the 'Ded' + * facts. */ +lemma NewKey_secrecy: + "not(Ex #i #j h k. NewKey(h, k) @ i & K(k) @ j) " + +end diff --git a/data/examples/stable/TLS.spthy b/data/examples/stable/TLS.spthy new file mode 100644 --- /dev/null +++ b/data/examples/stable/TLS.spthy @@ -0,0 +1,188 @@ +theory TLS +begin + +builtins: hashing, symmetric-encryption, asymmetric-encryption, signing + +section{* TLS Handshake *} + +/* + * Protocol: TLS Handshake + * Modeler: Simon Meier, minor update by Cas Cremers + * Date: January 2012 + * Source: Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy. + * + * Status: working (2.5 seconds on an i7 Quad-Core CPU with +RTS -N) + */ + +text{* + Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy. Notable + differences are: + + 1. We use explicit global constants to differentiate between different + encryptions instead of implicit typing. + + 2. We model session keys directly as hashes of the relevant information. + Due to our support for composed keys, we do not need any custom + axiomatization as Paulson does. + +*} + +functions: PRF/1 + +// Public key infrastructure +rule Register_pk: + [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ] + +rule Reveal_ltk: + [ !Ltk(A, ltkA) ] --[ RevLtk(A) ]-> [ Out(ltkA) ] + + +/* We formalize the following signature based TLS handshake. + + protocol TLS { + 1. C -> S: C, nc, sid, pc + 2. C <- S: ns, sid, ps + + 3. C -> S: { '31', pms }pk(S) , + sign{ '32', h('32', ns, S, pms) }pk(C) , + { '33', sid, PRF(pms, nc, ns), + nc, pc, C, ns, ps, S + } + h('clientKey', nc, ns, PRF(pms, nc, ns)) + + 4. C <- S: { '4', sid, PRF(pms, nc, ns), + nc, pc, C, ns, ps, S + } + h('serverKey', nc, ns, PRF(pms, nc, ns)) + } +*/ + +rule C_1: + [ Fr(~nc) + , Fr(~sid) + ] + --[]-> + [ Out( + <$C, ~nc, ~sid, $pc> + ) + , St_C_1($C, ~nc, ~sid, $pc) + ] + +rule S_1: + [ In( + <$C, nc, sid, pc> + ) + , Fr(~ns) + ] + --[]-> + [ Out( + <$S, ~ns, sid, $ps> + ) + , St_S_1($S, $C, sid, nc, pc, ~ns, $ps) + ] + +rule C_2: + let + MS = PRF(~pms, nc, ns) + Ckey = h('clientKey', nc, ns, MS) + in + [ St_C_1(C, nc, sid, pc) + , In( + + ) + , Fr(~pms) + , !Pk(S, pkS) + , !Ltk(C, ltkC) + ] + --[]-> + [ Out( + < aenc{ '31', ~pms }pkS + , sign{ '32', h('32', ns, S, ~pms) }ltkC + , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey + > + ) + , St_C_2(S, C, sid, nc, pc, ns, ps, ~pms) + ] + +rule S_2: + let + MS = PRF(pms, nc, ns) + Ckey = h('clientKey', nc, ns, MS) + Skey = h('serverKey', nc, ns, MS) + in + [ St_S_1(S, C, sid, nc, pc, ns, ps) + , In( + < aenc{ '31', pms }pk(ltkS) + , signature + , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey + > + ) + , !Pk(C, pkC) + , !Ltk(S, ltkS) + ] + /* Explicit equality check, enforced as part of the property. */ + --[ Eq(verify(signature, <'32', h('32', ns, S, pms)>, pkC), true ) + , SessionKeys( S, C, Skey, Ckey ) + ]-> + [ Out( + senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey + ) + ] + +rule C_3: + let + MS = PRF(pms, nc, ns) + Ckey = h('clientKey', nc, ns, MS) + Skey = h('serverKey', nc, ns, MS) + in + [ St_C_2(S, C, sid, nc, pc, ns, ps, pms) + , In( senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey ) + ] + --[ SessionKeys( S, C, Skey, Ckey ) ]-> + [] + + +/* TODO: Also model session-key reveals and adapt security properties. */ + + +/* Session key secrecy from the perspecitive of both the server and the client + * for both the key of the server and the key of the client. Note that this + * lemma thus captures four security properties at once. */ +lemma session_key_secrecy: + " /* If all equality checks succeeded */ + (All x y #i. Eq(x,y) @ i ==> x = y) + ==> + /* then there is no attack */ + (not( + /* It cannot be that */ + Ex S C keyS keyC #k. + /* somebody claims to have setup session keys, */ + SessionKeys(S, C, keyS, keyC) @ k + /* but the adversary knows one of them */ + & ( (Ex #i. K(keyS) @ i) + | (Ex #i. K(keyC) @ i) + ) + /* without having performed a long-term key reveal. */ + & not (Ex #r. RevLtk(S) @ r) + & not (Ex #r. RevLtk(C) @ r) + ) )" + +/* Consistency check: this lemma must NOT have a proof, + * as otherwise no session-keys could be setup between honest agents. */ +lemma session_key_setup_possible: + exists-trace + " /* There is a trace satisfying all equality checks */ + (All x y #i. Eq(x,y) @ i ==> x = y) + & /* Session keys have been setup */ + (Ex S C keyS keyC #k. SessionKeys(S, C, keyS, keyC) @ k + /* without having performed a long-term key reveal. */ + & not (Ex #r. RevLtk(S) @ r) + & not (Ex #r. RevLtk(C) @ r) + ) + " + + +end + diff --git a/data/examples/stable/Tutorial.spthy b/data/examples/stable/Tutorial.spthy new file mode 100644 --- /dev/null +++ b/data/examples/stable/Tutorial.spthy @@ -0,0 +1,403 @@ +/* +Tutorial for the Tamarin prover for security protocol analysis +============================================================== + +Authors: Simon Meier, Benedikt Schmidt +Date: April 2012 + + +Introduction +------------ + +This user guide assumes that you have a copy of our CSF'12 paper on +"Automated Analysis of Diffie-Hellman Protocols and Advanced Security +Properties", whose extended version is available from +http://www.infsec.ethz.ch/research/software#TAMARIN. + +The input files for the Tamarin prover have the extension .spthy, which is +short for 'security protocol theory'. A security protocol theory specifies + + 1. the signature and equational theory to use for the message algebra, + 2. the set of set of multiset rewriting rules modeling the protocol and + the adversary capabilities, and + 3. the guarded trace properties whose validity we wish to check for this + set of multiset rewriting rules. + +We explain each of these parts where they occur in the following security +protocol theory. Before we start, a few notes on the syntax. +As you probably noticed, comments are C-style. All identifiers are +case-sensitive. The parser is layout-insensitive, i.e., your are free to use +whitespace as it suits you. We provide a complete specification of the input +syntax in the reference MANUAL. + + +Modeling a security protocol +---------------------------- + +Every security protocol theory starts with a header of the following form. +*/ + +theory Tutorial +begin + +/* +Obviously, you can replace 'Tutorial' with any name you like to give your +theory. After 'begin', you can declare function symbols, equations that they +must satisfy, multiset rewriting rules, and lemmas specifying security +properties. Moreover, you can also insert formal comments, to structure your +theory. We give examples of each of these elements while modeling the +a simple protocol. + +In this protocol, a client C generates a fresh symmetric key 'k', encrypts it +with the public key of a server 'S' and sends it to 'S'. The server confirms +the receipt of the key by sending back its hash to the client. In +Alice-and-Bob notation the protocol would read as follows. + + C -> S: aenc{k}pk(S) + C <- S: h(k) + +This protocol is artificial and it satisfies only very weak security +guarantees. We can prove that from the perspective of the client, the freshly +generated key is secret provided that the server is uncompromised. + +We model this protocol in three steps. First, we declare the function symbols +and the equations defining them. Then, we introduce multiset rewriting rules +modeling a public key infrastructure (PKI) and the protocol. Finally, we state +the expected security properties. + + +Function Signature and Equational Theory +---------------------------------------- + +We model hashing using the unary function 'h'. +We model asymmetric encryption by declaring + a binary function 'aenc' denoting the encryption algorithm, + a binary function 'adec' denoting the decryption algorithm, and + a unary function 'pk' denoting the algorithm computing a public + key from a private key. +*/ + +functions: h/1, aenc/2, adec/2, pk/1 +equations: adec(aenc(m, pk(k)), k) = m + +/* +The above equation models the interaction between calls to these three +algorithms. All such user-specified equations must be subterm-convergent +rewriting rules, when oriented from left to right. This means that the +right-hand-side must be a subterm of the left-hand-side or a nullary +function symbol. + +Certain equational theories are used very often when modeling cryptographic +messages. We therefore provide builtins definitions for them. The above theory +could also be enabled using the declaration + + builtins: hashing, asymmetric-encryption + +We support the following builtins theories: + + diffie-hellman, signing, asymmetric-encryption, symmetric-encryption, + hashing + +Note that the theory for hashing only introduces the function symbol 'h/1' +and contains no equations. +Apart from 'diffie-hellman', all of these theories are subterm-convergent and +can therefore also be declared directly, as above. You can inspect their +definitions by uncommenting the following two line-comments and calling + + tamarin-prover Tutorial.spthy + +*/ + +// builtins: diffie-hellman, signing, asymmetric-encryption, symmetric-encryption, +// hashing + +/* +The call 'tamarin-prover Tutorial.spthy' parses the Tutorial.spthy file, +computes the variants of the multiset rewriting rules, checks their +wellformedness (explained below), and pretty-prints the theory. The +declaration of the signature and the equations can be found at the top of the +pretty-printed theory. + +Proving all lemmas contained in the theory is as simple as adding the +flag '--prove' to the call; i.e., + + tamarin-prover Tutorial.spthy --prove + +However, let's not go there yet. We first have to model the PKI and our +protocol. + + +Modeling the Public Key Infrastructure +-------------------------------------- +*/ + +// Registering a public key +rule Register_pk: + [ Fr(~ltk) ] + --> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)) ] + +/* The above rule models registering a public key. It makes use of the + following syntax. + + Facts always start with an upper-case letter and do not have to declared. + If their name is prefixed with an exclamation mark '!', then they are + persistent. Otherwise, they are linear. Note that you must use every fact + name consistently; i.e., you must always use it with the same arity, casing, + and multiplicity. Otherwise, the tamarin prover complains that the theory + is not wellformed. + + The 'Fr' fact is a builtins fact. It denotes a freshly generated fresh name. + See the paper for details. + + We denote the sort of variables using prefixes: + + ~x denotes x:fresh + $x denotes x:pub + #i denotes i:temp + i denotes i:msg + + 'c' denotes a public name 'c \in PN'; i.e., a fixed, global constant + + Thus, the above rule can be read as follows. First, freshly generate a + fresh name 'ltk', the new private key and nondeterministically choose a + public name 'A', the agent for which we are generating the key-pair. + Then, generate the persistent fact !Ltk($A, ~ltk), which denotes the + association between agent 'A' and its private key 'ltk, and generate the + persistent fact !Pk($A, pk(~ltk)), which denotes the association between the + agent 'A' and its public key 'pk(~ltk)'. + + We allow the adversary to retrieve any public key using the following rule. + Intuitively, it just reads a public-key database entry and sends the public + key to the network using the builtins fact 'Out' denoting a message sent to + the network. See our paper for more information. +*/ + +rule Get_pk: + [ !Pk(A, pk) ] + --> + [ Out(pk) ] + +/* + We model the dynamic compromise of long-term private keys using the following + rule. Intuitively, it reads a private-key database entry and sends it to + the adversary. This rule has an observable 'LtkReveal' action stating that + the long-term key of agent 'A' was compromised. We will use this action in + the security property below to determine which agents are compromised. +*/ + +rule Reveal_ltk: + [ !Ltk(A, ltk) ] + --[ LtkReveal(A) ]-> + [ Out(ltk) ] + + +/* + +Modeling the protocol +---------------------- + +Recall that we want to model the following protocol. + + C -> S: aenc{k}pk(S) + C <- S: h(k) + +We model it use the following three rules. +*/ + +// Start a new thread executing the client role, choosing the server +// non-deterministically. +rule Client_1: + [ Fr(~k) // choose fresh key + , !Pk($S, pkS) // lookup public-key of server + ] + --> + [ Client_1( $S, ~k ) // Store server and key for next step of thread + , Out( aenc{'1', ~k}pkS ) // Send the encrypted session key to the server + // We add the tag '1' to the request to allow + // the server to check whether the decryption + // was successful. + ] + +rule Client_2: + [ Client_1(S, k) // Retrieve server and session key from previous step + , In( h(k) ) // Receive hashed session key from network + ] + --[ SessKeyC( S, k ) ]-> // State that the session key 'k' + [] // was setup with server 'S' + +// A server thread answering in one-step to a session-key setup request from +// some client. +rule Serv_1: + [ !Ltk($S, ~ltkS) // lookup the private-key + , In( request ) // receive a request + ] + --[ Eq(fst(adec(request, ~ltkS)), '1') + , AnswerRequest($S, snd(adec(request, ~ltkS))) // Explanation below + ]-> + [ Out( h(snd(adec(request, ~ltkS))) ) ] // Return the hash of the + // decrypted request. + +/* Above, we model all applications of cryptographic algorithms explicitly. + Call 'tamarin-prover Tutorial.spthy' to inspect the finite variants of the + Serv_1 rule, which list all possible interactions of the destructors used. + In our proof search, we will consider all these interactions. + + We also model that the server explicitly checks that the first component of + the request is equal to '1'. We model this by logging the claimed equality + and then adapting the security property such that it only considers traces + where all 'Eq' actions occur with two equal arguments. Note that 'Eq' is NO + builtin fact. Guarded trace properties are strong enough to formalize this + requirement without builtin support. Note that inequalities can be modeled + analogously. + + We log the session-key setup requests received by servers to allow + formalizing the authentication property for the client. + + +Modeling the security properties +-------------------------------- + +The syntax for specifying security properties uses + + All for universal quantification, temporal variables are prefixed with # + Ex for existential quantification, temporal variables are prefixed with # + ==> for implication + & for conjunction + | for disjunction + not for negation + + f @ i for action constraints, the sort prefix for the temporal variable 'i' + is optional + + i < j for temporal ordering, the sort prefix for the temporal variables 'i' + adn 'j' is optional + + #i = #j for an equality between temporal variables 'i' and 'j' + x = y for an equality between message variables 'x' and 'y' + +Note that apart from public names (delimited using single-quotes), no terms +may occur in guarded trace properties. Moreover, all variables must be +guarded. The error message for an unguarded variable is currently not very +good. + +For universally quantified variables, one has to check that they all occur in +an action constraint right after the quantifier and that the outermost logical operator +inside the quantifier is an implication. +For existentially quantified variables, one has to check that they all occur in +an action constraint right after the quantifier and that the outermost logical +operator inside the quantifier is a conjunction. +Note also that currently the precedence of the logical connectives is not +specified. We therefore recommend to use parentheses, when in doubt. + + +The following two properties should be self-explanatory. +*/ + +lemma Client_session_key_secrecy: + " /* For all traces, where all equality checks succeed, */ + (All x y #i. Eq(x,y) @ i ==> x = y) + ==> + /* it cannot be that a */ + not( + Ex S k #i #j. + /* client setup a session key 'k' with a server'S' */ + SessKeyC(S, k) @ #i + /* and the adversary knows 'k' */ + & K(k) @ #j + /* without having performed a long-term key reveal on 'S'. */ + & not(Ex #r. LtkReveal(S) @ r) + ) + " + + +lemma Client_auth: + " /* For all traces, where all equality checks succeed, */ + (All x y #i. Eq(x,y) @ i ==> x = y) + ==> + /* for all session keys 'k' setup by clients with a server 'S' */ + ( All S k #i. SessKeyC(S, k) @ #i + ==> + /* there is a server that answered the request */ + ( (Ex #a. AnswerRequest(S, k) @ a) + /* or the intruder performed a long-term key reveal on 'S' + before the key was setup. */ + | (Ex #r. LtkReveal(S) @ r & r < i) + ) + ) + " + +/* + You can verify them by calling + + tamarin-prover --prove Tutorial.spthy + + This will first output some logging from the constraint solver and then the + Tutorial security protocol theory with the lemmas and their attached + (dis)proofs. + + Finding attacks is very useful, to check that a security property is not + trivial due to too strong preconditions. The following property must not be + provable, as otherwise there would be no possibility to setup a session key + with a honest sever. + + We can check for the existence of a trace using the 'exists-trace' + quantifier in front of the trace formula. When modeling protocols such + existence proof are very useful sanity checks. +*/ +lemma Client_session_key_honest_setup: + exists-trace + " (All x y #i. Eq(x,y) @ i ==> x = y) + & ( + Ex S k #i. + SessKeyC(S, k) @ #i + & not(Ex #r. LtkReveal(S) @ r) + ) + " + +/* + +Interactive proof visualization and construction +------------------------------------------------ + +Just call + + tamarin-prover interactive Tutorial.spthy + +This will start a web-server that loads all security protocol theories in the +same directory as Tutorial.spthy. Point your browser to + + http://localhost:3001 + +and explore the the Tutorial theory interactively by clicking on the +'Tutorial' entry in the table of loaded theories. You can prove a lemma +interactively by clicking on the available proof methods (corresponding to +applications of constraint reduction rules) or by calling the 'autoprover' by +right-clicking on a node in the theory overview. Note that that the proof +methods in the GUI are sorted according to our heuristic. Always selecting the +first proof method will result in the same proof as the ones constructed by +the 'autoprover' and '--prove'. + + +Conclusion +---------- + +By now, you should have enough knowledge to understand the case studies from +our CSF'12 paper. Recall that you can find them in the directory listed at the +bottom of the help message, when calling 'tamarin-prover' without any +arguments. Note that Tamarin also outputs the path to the reference MANUAL +specifying and explaining the grammar of security protocol theories and giving +some additional hints on additional theory exploited by Tamarin. If you have +further questions, please do not hesitate to contact either + + Benedikt Schmidt benedikt.schmidt@inf.ethz.ch + Simon Meier simon.meier@inf.ethz.ch + Cas Cremers cas.cremers@inf.ethz.ch + + +BTW, every security protocol theory must be delimited with 'end'. + + (-: HAPPY PROVING :-) +*/ + +end diff --git a/data/img/favicon.ico b/data/img/favicon.ico Binary files a/data/img/favicon.ico and b/data/img/favicon.ico differ diff --git a/data/img/tamarin-logo-128.png b/data/img/tamarin-logo-128.png new file mode 100644 Binary files /dev/null and b/data/img/tamarin-logo-128.png differ diff --git a/data/img/tamarin-logo-3-0-0.png b/data/img/tamarin-logo-3-0-0.png new file mode 100644 Binary files /dev/null and b/data/img/tamarin-logo-3-0-0.png differ diff --git a/data/img/tamarin-logo-3-1-0.png b/data/img/tamarin-logo-3-1-0.png new file mode 100644 Binary files /dev/null and b/data/img/tamarin-logo-3-1-0.png differ diff --git a/data/img/tamarin-logo-32.png b/data/img/tamarin-logo-32.png new file mode 100644 Binary files /dev/null and b/data/img/tamarin-logo-32.png differ diff --git a/data/img/tamarin-logo-64.png b/data/img/tamarin-logo-64.png new file mode 100644 Binary files /dev/null and b/data/img/tamarin-logo-64.png differ diff --git a/data/img/tamarin-logo-96.png b/data/img/tamarin-logo-96.png new file mode 100644 Binary files /dev/null and b/data/img/tamarin-logo-96.png differ diff --git a/data/intruder_variants_dh.spthy b/data/intruder_variants_dh.spthy --- a/data/intruder_variants_dh.spthy +++ b/data/intruder_variants_dh.spthy @@ -1,272 +1,258 @@ -theory intruder_variants begin +rule (modulo AC) cexp: + [ !KU( 'exp', x ), !KU( f_.2, x.1 ) ] + --[ Ded( x^x.1 ) ]-> + [ !KU( 'noexp', x^x.1 ) ] - builtin: diffie-hellman +rule (modulo AC) cinv: + [ !KU( f_.1, x ) ] --[ Ded( inv(x) ) ]-> [ !KU( 'exp', inv(x) ) ] -section{* Finite Variants of the Intruder Rules *} +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, x.1 ) ] + --> + [ !KD( 'noexp', x.3^(x.1*x.4) ) ] - rule (modulo AC) exp: - [ !KU( 'noexp', x ), !KU( f_.2, x.1 ) ] --> [ !KU( 'exp', x^x.1 ) ] - - rule (modulo AC) inv: - [ !KU( f_.1, x ) ] --> [ !KU( 'noexp', inv(x) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, x.1 ) ] - --> - [ !KD( 'exp', x.3^(x.1*x.4) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^x.3 ), !KU( f_.2, inv(x.3) ) ] - --> - [ !KD( 'exp', x.4 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^inv(x.3) ), !KU( f_.2, x.3 ) ] - --> - [ !KD( 'exp', x.4 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^inv(x.5) ), !KU( f_.2, inv(x.3) ) ] - --> - [ !KD( 'exp', x.4^inv((x.3*x.5)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^inv((x.3*x.5)) ), !KU( f_.2, x.3 ) ] - --> - [ !KD( 'exp', x.4^inv(x.5) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^(x.3*x.5) ), !KU( f_.2, inv(x.3) ) ] - --> - [ !KD( 'exp', x.4^x.5 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^(x.5*inv(x.3)) ), !KU( f_.2, x.3 ) ] - --> - [ !KD( 'exp', x.4^x.5 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, inv((x.4*x.5)) ) ] - --> - [ !KD( 'exp', x.3^inv(x.5) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, (x.5*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.3^x.5 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^inv(x.4) ), !KU( f_.2, (x.3*x.4) ) ] - --> - [ !KD( 'exp', x.5^x.3 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^(x.5*inv(x.6)) ), !KU( f_.2, inv(x.3) ) ] - --> - [ !KD( 'exp', x.4^(x.5*inv((x.3*x.6))) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^inv(x.4) ), !KU( f_.2, (x.5*inv(x.6)) ) ] - --> - [ !KD( 'exp', x.3^(x.5*inv((x.4*x.6))) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.4^(x.5*inv((x.3*x.6))) ), !KU( f_.2, x.3 ) ] - --> - [ !KD( 'exp', x.4^(x.5*inv(x.6)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^inv((x.4*x.6)) ), !KU( f_.2, (x.3*x.4) ) ] - --> - [ !KD( 'exp', x.5^(x.3*inv(x.6)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.4*x.6) ), !KU( f_.2, inv((x.3*x.4)) ) ] - --> - [ !KD( 'exp', x.5^(x.6*inv(x.3)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.4*x.6) ), !KU( f_.2, (x.3*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.5^(x.3*x.6) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.6*inv(x.4)) ), !KU( f_.2, (x.3*x.4) ) ] - --> - [ !KD( 'exp', x.5^(x.3*x.6) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ] - --> - [ !KD( 'exp', x.3^(x.5*inv(x.6)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.6*inv(x.7)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.5^(x.3*x.6*inv((x.4*x.7))) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.4*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.5 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.4*inv(x.6)) ), !KU( f_.2, inv((x.3*x.4)) ) ] - --> - [ !KD( 'exp', x.5^inv((x.3*x.6)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^inv((x.3*x.6)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.5^inv((x.4*x.6)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.6*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4) ) ] - --> - [ !KD( 'exp', x.5^(x.3*x.6*inv(x.7)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^(x.4*x.5) ), !KU( f_.2, (x.6*inv((x.5*x.7))) ) ] - --> - [ !KD( 'exp', x.3^(x.4*x.6*inv(x.7)) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.4*x.6*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.5^x.6 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.6^(x.5*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ] - --> - [ !KD( 'exp', x.6^x.3 ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.4*x.6*inv(x.7)) ), !KU( f_.2, inv((x.3*x.4)) ) ] - --> - [ !KD( 'exp', x.5^(x.6*inv((x.3*x.7))) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.6^inv((x.4*x.7)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ] - --> - [ !KD( 'exp', x.6^(x.3*inv((x.5*x.7))) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.4*inv((x.3*x.6))) ), !KU( f_.2, (x.3*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.5^inv(x.6) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ] - --> - [ !KD( 'exp', x.3^inv(x.6) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.6*inv((x.4*x.7))) ) ] - --> - [ !KD( 'exp', x.3^(x.6*inv((x.5*x.7))) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.6^(x.5*x.7*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) - ] - --> - [ !KD( 'exp', x.6^(x.3*x.7) ) ] - - rule (modulo AC) exp: - [ !KD( 'noexp', x.5^(x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) ) ] - --> - [ !KD( 'exp', x.5^(x.6*inv((x.4*x.7))) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*x.6*inv((x.4*x.7))) ) - ] - --> - [ !KD( 'exp', x.3^(x.6*inv(x.7)) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.5^(x.4*x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) ) - ] - --> - [ !KD( 'exp', x.5^(x.6*inv(x.7)) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.6^(x.5*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) - ] - --> - [ !KD( 'exp', x.6^(x.3*inv(x.7)) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.6^(x.5*x.7*inv(x.3)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) ) - ] - --> - [ !KD( 'exp', x.6^(x.7*inv(x.4)) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.6^(x.5*x.7*inv(x.8)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) ) - ] - --> - [ !KD( 'exp', x.6^(x.3*x.7*inv((x.4*x.8))) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.6^(x.7*inv((x.4*x.8))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) - ] - --> - [ !KD( 'exp', x.6^(x.3*x.7*inv((x.5*x.8))) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.6^(x.5*inv((x.3*x.7))) ), - !KU( f_.2, (x.3*inv((x.4*x.5))) ) - ] - --> - [ !KD( 'exp', x.6^inv((x.4*x.7)) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.3^(x.4*x.5*inv(x.6)) ), - !KU( f_.2, (x.6*x.7*inv((x.5*x.8))) ) - ] - --> - [ !KD( 'exp', x.3^(x.4*x.7*inv(x.8)) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.6^(x.5*x.7*inv((x.4*x.8))) ), - !KU( f_.2, (x.3*x.4*inv(x.5)) ) - ] - --> - [ !KD( 'exp', x.6^(x.3*x.7*inv(x.8)) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.7^(x.6*inv((x.4*x.8))) ), - !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) ) - ] - --> - [ !KD( 'exp', x.7^(x.3*inv((x.5*x.8))) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.6^(x.5*x.7*inv((x.3*x.8))) ), - !KU( f_.2, (x.3*inv((x.4*x.5))) ) - ] - --> - [ !KD( 'exp', x.6^(x.7*inv((x.4*x.8))) ) ] - - rule (modulo AC) exp: - [ - !KD( 'noexp', x.7^(x.6*x.8*inv((x.4*x.9))) ), - !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) ) - ] - --> - [ !KD( 'exp', x.7^(x.3*x.8*inv((x.5*x.9))) ) ] - - rule (modulo AC) inv: - [ !KD( f_.1, inv(x.2) ) ] --> [ !KD( 'noexp', x.2 ) ] +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^x.3 ), !KU( f_.2, inv(x.3) ) ] + --> + [ !KD( 'noexp', x.4 ) ] -end +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^inv(x.3) ), !KU( f_.2, x.3 ) ] + --> + [ !KD( 'noexp', x.4 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^inv(x.5) ), !KU( f_.2, inv(x.3) ) ] + --> + [ !KD( 'noexp', x.4^inv((x.3*x.5)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^inv((x.3*x.5)) ), !KU( f_.2, x.3 ) ] + --> + [ !KD( 'noexp', x.4^inv(x.5) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^(x.3*x.5) ), !KU( f_.2, inv(x.3) ) ] + --> + [ !KD( 'noexp', x.4^x.5 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^(x.5*inv(x.3)) ), !KU( f_.2, x.3 ) ] + --> + [ !KD( 'noexp', x.4^x.5 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, inv((x.4*x.5)) ) ] + --> + [ !KD( 'noexp', x.3^inv(x.5) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, (x.5*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.3^x.5 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^inv(x.4) ), !KU( f_.2, (x.3*x.4) ) ] + --> + [ !KD( 'noexp', x.5^x.3 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^(x.5*inv(x.6)) ), !KU( f_.2, inv(x.3) ) ] + --> + [ !KD( 'noexp', x.4^(x.5*inv((x.3*x.6))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^inv(x.4) ), !KU( f_.2, (x.5*inv(x.6)) ) ] + --> + [ !KD( 'noexp', x.3^(x.5*inv((x.4*x.6))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.4^(x.5*inv((x.3*x.6))) ), !KU( f_.2, x.3 ) ] + --> + [ !KD( 'noexp', x.4^(x.5*inv(x.6)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^inv((x.4*x.6)) ), !KU( f_.2, (x.3*x.4) ) ] + --> + [ !KD( 'noexp', x.5^(x.3*inv(x.6)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*x.6) ), !KU( f_.2, inv((x.3*x.4)) ) ] + --> + [ !KD( 'noexp', x.5^(x.6*inv(x.3)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*x.6) ), !KU( f_.2, (x.3*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.5^(x.3*x.6) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.6*inv(x.4)) ), !KU( f_.2, (x.3*x.4) ) ] + --> + [ !KD( 'noexp', x.5^(x.3*x.6) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ] + --> + [ !KD( 'noexp', x.3^(x.5*inv(x.6)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.6*inv(x.7)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.5^(x.3*x.6*inv((x.4*x.7))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.5 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*inv(x.6)) ), !KU( f_.2, inv((x.3*x.4)) ) ] + --> + [ !KD( 'noexp', x.5^inv((x.3*x.6)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^inv((x.3*x.6)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.5^inv((x.4*x.6)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.6*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4) ) ] + --> + [ !KD( 'noexp', x.5^(x.3*x.6*inv(x.7)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^(x.4*x.5) ), !KU( f_.2, (x.6*inv((x.5*x.7))) ) ] + --> + [ !KD( 'noexp', x.3^(x.4*x.6*inv(x.7)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*x.6*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.5^x.6 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.6^(x.5*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ] + --> + [ !KD( 'noexp', x.6^x.3 ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*x.6*inv(x.7)) ), !KU( f_.2, inv((x.3*x.4)) ) ] + --> + [ !KD( 'noexp', x.5^(x.6*inv((x.3*x.7))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.6^inv((x.4*x.7)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ] + --> + [ !KD( 'noexp', x.6^(x.3*inv((x.5*x.7))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*inv((x.3*x.6))) ), !KU( f_.2, (x.3*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.5^inv(x.6) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ] + --> + [ !KD( 'noexp', x.3^inv(x.6) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.6*inv((x.4*x.7))) ) ] + --> + [ !KD( 'noexp', x.3^(x.6*inv((x.5*x.7))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.6^(x.5*x.7*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ] + --> + [ !KD( 'noexp', x.6^(x.3*x.7) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) ) ] + --> + [ !KD( 'noexp', x.5^(x.6*inv((x.4*x.7))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*x.6*inv((x.4*x.7))) ) + ] + --> + [ !KD( 'noexp', x.3^(x.6*inv(x.7)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.5^(x.4*x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) ) + ] + --> + [ !KD( 'noexp', x.5^(x.6*inv(x.7)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.6^(x.5*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) + ] + --> + [ !KD( 'noexp', x.6^(x.3*inv(x.7)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.6^(x.5*x.7*inv(x.3)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) ) + ] + --> + [ !KD( 'noexp', x.6^(x.7*inv(x.4)) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.6^(x.5*x.7*inv(x.8)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) ) + ] + --> + [ !KD( 'noexp', x.6^(x.3*x.7*inv((x.4*x.8))) ) ] + +rule (modulo AC) dexp: + [ !KD( 'exp', x.6^(x.7*inv((x.4*x.8))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) + ] + --> + [ !KD( 'noexp', x.6^(x.3*x.7*inv((x.5*x.8))) ) ] + +rule (modulo AC) dexp: + [ + !KD( 'exp', x.6^(x.5*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv((x.4*x.5))) ) + ] + --> + [ !KD( 'noexp', x.6^inv((x.4*x.7)) ) ] + +rule (modulo AC) dexp: + [ + !KD( 'exp', x.3^(x.4*x.5*inv(x.6)) ), + !KU( f_.2, (x.6*x.7*inv((x.5*x.8))) ) + ] + --> + [ !KD( 'noexp', x.3^(x.4*x.7*inv(x.8)) ) ] + +rule (modulo AC) dexp: + [ + !KD( 'exp', x.6^(x.5*x.7*inv((x.4*x.8))) ), + !KU( f_.2, (x.3*x.4*inv(x.5)) ) + ] + --> + [ !KD( 'noexp', x.6^(x.3*x.7*inv(x.8)) ) ] + +rule (modulo AC) dexp: + [ + !KD( 'exp', x.7^(x.6*inv((x.4*x.8))) ), + !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) ) + ] + --> + [ !KD( 'noexp', x.7^(x.3*inv((x.5*x.8))) ) ] + +rule (modulo AC) dexp: + [ + !KD( 'exp', x.6^(x.5*x.7*inv((x.3*x.8))) ), + !KU( f_.2, (x.3*inv((x.4*x.5))) ) + ] + --> + [ !KD( 'noexp', x.6^(x.7*inv((x.4*x.8))) ) ] + +rule (modulo AC) dexp: + [ + !KD( 'exp', x.7^(x.6*x.8*inv((x.4*x.9))) ), + !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) ) + ] + --> + [ !KD( 'noexp', x.7^(x.3*x.8*inv((x.5*x.9))) ) ] + +rule (modulo AC) dinv: + [ !KD( f_.1, inv(x.2) ) ] --> [ !KD( 'exp', x.2 ) ] diff --git a/data/js/tamarin-prover-ui.js b/data/js/tamarin-prover-ui.js --- a/data/js/tamarin-prover-ui.js +++ b/data/js/tamarin-prover-ui.js @@ -1,5 +1,5 @@ /** - * Dh-proto-proof ui controller + * Tamarin ui controller * @author Cedric Staub */ @@ -9,13 +9,22 @@ var theory = { /** - * Convert a relative path into an absolute one. - * @param section Section/display, for example main or debug. + * Convert a relative path into an absolute one for the currently shown theory. + * @param action The action, for example "overview" or "main". * @param path The relative path. * @return The absolute path. */ absolutePath: function(section, path) { return "/thy/" + this.idx + "/" + section + "/" + path; + }, + + /** + * Extract the theory path from the given url path. + * @param urlPath The url path + * @return The theory path. + */ + extractTheoryPath : function(urlPath) { + return urlPath.split("/").splice(4).join("/"); } } @@ -138,10 +147,11 @@ // Add keyboard shortcuts var shortcuts = { - 74 : function() { proofScript.jump('next/smart', null); }, - 75 : function() { proofScript.jump('prev/smart', null); }, - 106 : function() { proofScript.jump('next/normal', null); }, - 107 : function() { proofScript.jump('prev/normal', null); } + 97 : function() { mainDisplay.applyAutoprover(); }, // a + 74 : function() { proofScript.jump('next/smart', null); }, // j + 75 : function() { proofScript.jump('prev/smart', null); }, // k + 106 : function() { proofScript.jump('next/normal', null); }, // J + 107 : function() { proofScript.jump('prev/normal', null); } // K } for(i = 1; i < 10; i++) { @@ -152,6 +162,13 @@ this.add_shortcuts(shortcuts); + // set active link + path = window.location.pathname.split("/"); + path[3] = "main"; + this.setActiveLink(path.join("/")); + proofScript.focusActive(); + + // Initialize dialog box $("div#dialog").dialog({ autoOpen: false, @@ -168,14 +185,11 @@ $("#proof a.proof-step").contextMenu( { menu: "contextMenu" }, function(action, el, pos) { + var theoryPath = theory.extractTheoryPath($(el).attr("href")); mainDisplay.loadTarget( - action, - $(el).attr("href"), - function() { - var path = $(el).attr("href"); - $.cookie("last-target", path, { path: "/" }); - $.cookie("jump-to-target", true, { path: "/" }); - }); + theory.absolutePath(action,theoryPath), + null + ); }); // Click handler for save link @@ -233,15 +247,7 @@ "div#proof a.internal-link", "main", null); - - // Install handlers on edit links (lemma) - events.installRelativeClickHandler( - "div#proof a.internal-link.edit-link", - "edit/path", - function(el) { - events.installFormHandler(); - }); - + // Install handlers on delete links events.installRelativeClickHandler( "div#proof a.internal-link.delete-link", @@ -252,21 +258,21 @@ events.installRelativeClickHandler( "div#proof a.internal-link.proof-step", "main", - function(el) { - var path = $(el).attr("href"); - $.cookie("last-target", path, { path: "/" }); - $.cookie("jump-next-open-goal", true, { path: "/" }); - }); - + null + ); + + // Install click handlers on main + events.installRelativeClickHandler( + "div#ui-main-display a.internal-link", + "main", + null); + // Install handlers on removal links events.installRelativeClickHandler( "div#proof a.internal-link.remove-step", "del/path", - function(el) { - var path = $(el).attr("href"); - $.cookie("last-target", path, { path: "/" }); - $.cookie("jump-to-target", true, { path: "/" }); - }); + null + ); }, /** @@ -341,7 +347,18 @@ var dialog = $("div#dialog"); dialog.html(msg.replace("\n","
")); dialog.dialog('open'); + }, + + /** + * Set active link + * @param target The path + */ + setActiveLink: function(target) { + var selector = "a.internal-link[href='" + target + "']"; + $("a.active-link").removeClass("active-link"); + $(selector).first().addClass("active-link"); } + } @@ -400,7 +417,7 @@ ev.preventDefault(); var element = $(this); mainDisplay.loadTarget( - section, + // section, element.attr("href"), function() { if(callback) callback(element); @@ -419,10 +436,11 @@ cancel.click(function(ev) { ev.preventDefault(); + // FIXME: where to jump here if($.cookie("last-target")) { - mainDisplay.loadTarget("main", $.cookie("last-target")); + mainDisplay.loadTarget($.cookie("last-target")); } else { - mainDisplay.loadTarget("main", "rules"); + mainDisplay.loadTarget("rules"); } }); @@ -486,9 +504,9 @@ if(active.length > 0) { var current = active.attr("href"); - + server.performASR( - theory.absolutePath(mode, current), + theory.absolutePath(mode, theory.extractTheoryPath(current)), "text", false, // Success callback @@ -498,7 +516,7 @@ if(link.length > 0) { mainDisplay.loadTarget( - "main", + // "main", link.attr("href"), function() { proofScript.focusActive(); @@ -566,23 +584,34 @@ */ applyProofMethod: function(num) { var path = $("a.active-link").attr("href"); - $.cookie("last-target", path, { path: "/" }); - $.cookie("jump-next-open-goal", true, { path: "/" }); var element = $("#ui-main-display"); var methods = element.find("div.methods a.internal-link"); - if(methods.length >= num) { - $(methods.get([ num - 1 ])).click(); - } + if(methods.length >= num) $(methods.get([ num - 1 ])).click(); }, + applyAutoprover: function() { + var auto = $("#ui-main-display").find("a.internal-link.autoprove"); + + if(auto.length >= 1) $(auto.get(0)).click(); + }, + + /** * Update main view with new HTML data. * @param html_data The html data. */ setContent: function(title, html_data) { - if(title) $("#main-title").html(title); + if(title) { + // Only use first line for title + var titleLines = title.split('
'); + var titleText = titleLines[0]; + if(titleLines.length > 1 && titleLines[1] != "") { + titleText = titleText + " ..." + } + $("#main-title").html(titleText); + } var element = $("#ui-main-display"); var wrapper = $("#main-wrapper"); @@ -628,10 +657,10 @@ * @param target The target to load. * @param callback Optional callback to call after successful load. */ - loadTarget: function(section, target, callback) { + loadTarget: function(target, callback) { // Load main view server.performASR( - theory.absolutePath(section, target), + target, "json", false, // Success callback @@ -640,23 +669,12 @@ server.handleJson(data, function(title, html_data) { mainDisplay.setContent(title, html_data); - // Set active-link class for target - var selector = "a.internal-link[href='" + target + "']"; - $("a.active-link").removeClass("active-link"); - $(selector).first().addClass("active-link"); - - /* - // Load debug view - server.performASR( - theory.absolutePath('debug', target), - "html", - false, - // Success callback - function(data, textStatus) { - $("#ui-debug-display").html(data); - } - ); - */ + if (window.history && window.history.pushState) { + var url = theory.absolutePath("overview", theory.extractTheoryPath(target)); + window.history.replaceState({}, "", url); + } + + ui.setActiveLink(target); }); // Call optional callback @@ -692,14 +710,6 @@ * Initialize when document is ready. */ $(document).ready(function() { - // Automatically submit upload form on root - $("input[type=file]").change(function() { - var obj = $(this); - if(obj.val()) { - obj.parents("form").submit(); - } - }); - // Only run rest of script if the main display is available var main_display = $("#ui-main-display"); if(main_display.length != 1) return; @@ -730,18 +740,4 @@ // Initialize user interface ui.init(); - - // Process jump instructions - if($.cookie("jump-to-target")) { - if($.cookie("last-target")) { - proofScript.jumpToTarget($.cookie("last-target")); - } - $.cookie("jump-to-target", null, { path: "/" }); - } else if($.cookie("jump-next-open-goal")) { - if($.cookie("last-target")) { - proofScript.jumpNextOpenGoal($.cookie("last-target")); - } - $.cookie("jump-next-open-goal", null, { path: "/" }); - } - }); diff --git a/interactive-only-src/Paths_tamarin_prover.hs b/interactive-only-src/Paths_tamarin_prover.hs --- a/interactive-only-src/Paths_tamarin_prover.hs +++ b/interactive-only-src/Paths_tamarin_prover.hs @@ -12,7 +12,7 @@ version :: Version -version = Version {versionBranch = [0,1,0], versionTags = []} +version = Version {versionBranch = [0,4,0,0], versionTags = []} bindir, libdir, datadir, libexecdir :: FilePath bindir = "./" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,721 +1,18 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} -- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE) -- -- Maintainer : Simon Meier --- Portability : GHC only -- --- Main module for the tamarin prover. +-- Main module for the Tamarin prover without a GUI module Main where -import Prelude hiding (id, (.)) - -import Data.List -import Data.Maybe -import Data.Version (showVersion) -import Data.Monoid -import Data.Char (isSpace, toLower) -import Data.Label - -import Control.Basics -import Control.Category -import Control.Exception as E - -import System.Console.CmdArgs.Explicit -import System.Console.CmdArgs.Text - -import System.Exit -import System.FilePath -import System.Directory -import System.Environment -import System.IO -import System.Process -import System.Timing (timed) - -import Extension.Prelude - -import qualified Text.Isar as Isar - -import Theory -import Theory.Parser -import Theory.Wellformedness - -import Paths_tamarin_prover - -import Web.Dispatch -import qualified Web.Settings -import qualified Network.Wai.Handler.Warp as Warp (run) - ------------------------------------------------------------------------------- --- General definitions for tamarin ------------------------------------------------------------------------------- - --- | Program name -programName :: String -programName = "tamarin-prover" - --- | Version string -versionStr :: FilePath -- ^ Path to LICENCE file. - -> String -versionStr licensePath = unlines - [ concat - [ programName - , " " - , showVersion version - , ", (C) Benedikt Schmidt, Simon Meier, ETH Zurich 2010-2012" - ] - , "" - , "This program comes with ABSOLUTELY NO WARRANTY. It is free software, and you" - , "are welcome to redistribute it according to its LICENSE, see" - , "'" ++ licensePath ++ "'." - ] - --- | Line width to use. -lineWidth :: Int -lineWidth = 110 - -shortLineWidth :: Int -shortLineWidth = 78 - -{- --- | Version string with HTML markup. -htmlVersionStr :: String -htmlVersionStr = concat - [ link "http://www.infsec.ethz.ch/research/software#TAMARIN" programName - , " " - , showVersion version - , ", © " - , link "https://infsec.ethz.ch/infsec/people/benschmi/index" "Benedikt Schmidt" - , ", " - , link "http://people.inf.ethz.ch/meiersi" "Simon Meier" - , ", ETH Zurich 2010-2012" - ] - where - link href name = - "" ++ name ++ "" --} - ------------------------------------------------------------------------------- --- Argument parsing helpers ------------------------------------------------------------------------------- - -type Arguments = [(String,String)] - -argExists :: String -> Arguments -> Bool -argExists a = isJust . findArg a - -findArg :: MonadPlus m => String -> Arguments -> m String -findArg a' as = msum [ return v | (a,v) <- as, a == a' ] - -getArg :: String -> Arguments -> String -getArg a = - fromMaybe (error $ "getArg: argument '" ++ a ++ "' not found") . findArg a - -addArg :: String -> String -> Arguments -> Arguments -addArg a v = ((a,v):) - -withArguments :: Mode Arguments -> (Arguments -> IO ()) -> IO () -withArguments argMode io = do - licensePath <- getDataFileName "LICENSE" - processArgs argMode >>= run licensePath - where - run licensePath as - | argExists "help" as = print $ helpText HelpFormatAll argMode - | argExists "version" as = putStrLn $ versionStr licensePath - | otherwise = io as - -updateArg :: String -> String -> Arguments -> Either a Arguments -updateArg a v = Right . addArg a v - -addEmptyArg :: String -> Arguments -> Arguments -addEmptyArg a = addArg a "" - --- | Main mode. -mainMode :: Mode [(String,String)] -mainMode = - -- translateMode { modeGroupModes = toGroup [interactiveMode] } - translateMode { modeGroupModes = toGroup [interactiveMode, intruderMode] } - where - - defaultMode name help = Mode - { modeGroupModes = toGroup [] - , modeNames = [name] - , modeValue = [] - , modeCheck = updateArg "mode" name - , modeReform = const Nothing-- no reform possibility - , modeHelp = help - , modeHelpSuffix = [] - , modeArgs = Nothing -- no positional arguments - , modeGroupFlags = toGroup [] -- no flags - } - - translateMode = - ( defaultMode programName - "Batch mode for analyzing security protocols using DH-exponentiation." - ) - { modeCheck = updateArg "mode" "translate" - , modeArgs = Just $ flagArg (updateArg "inFile") "FILES" - , modeGroupFlags = Group - { groupUnnamed = - theoryLoadFlags ++ - -- [ flagNone ["html"] (addEmptyArg "html") - -- "generate HTML visualization of proofs" - - -- [ flagNone ["no-compress"] (addEmptyArg "noCompress") - -- "Do not use compressed sequent visualization" - - [ flagNone ["parse-only"] (addEmptyArg "parseOnly") - "Parse the input file and pretty-print it as-is" - ] ++ - outputFlags ++ - toolFlags - , groupHidden = [] - , groupNamed = - [ ("About" - , [ flagHelpSimple (addEmptyArg "help") - , flagVersion (addEmptyArg "version") - ] ) - ] - } - } - - - intruderMode = - ( defaultMode "intruder" - "Compute the variants of the intruder rules for DH-exponentiation." - ) - { modeArgs = Nothing - , modeCheck = updateArg "mode" "intruder" - , modeGroupFlags = toGroup outputFlags - } - - outputFlags = - [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file" - , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR" "Output directory" - ] - - toolFlags = - -- [ flagOpt "dot" ["with-dot"] (updateArg "withDot") "FILE" "Path to GraphViz 'dot' tool" - [ flagOpt "maude" ["with-maude"] (updateArg "withMaude") "FILE" "Path to 'maude' rewriting tool" - ] - - interactiveFlags = - [ flagOpt "" ["port","p"] (updateArg "port") "PORT" "Port to listen on" - -- , flagOpt "" ["datadir"] (updateArg "datadir") "DATADIR" "Directory with data" - , flagNone ["debug"] (addEmptyArg "debug") "Show server debugging output" - -- , flagNone ["autosave"] (addEmptyArg "autosave") "Automatically save proof state" - -- , flagNone ["loadstate"] (addEmptyArg "loadstate") "Load proof state if present" - ] ++ - theoryLoadFlags ++ - toolFlags - - interactiveMode = - ( defaultMode "interactive" - "Start a web-server for interactively constructing the security proofs." - ) - { modeArgs = Just $ flagArg (updateArg "workDir") "WORKDIR" - , modeCheck = updateArg "mode" "interactive" - , modeGroupFlags = toGroup interactiveFlags - } - - --- | Disply help message and exit. -errHelpExit :: String -> IO () -errHelpExit msg = do - putStrLn $ "error: " ++ msg - putStrLn $ "" - putStrLn $ showText (Wrap lineWidth) - $ helpText HelpFormatDefault mainMode - examplePath <- getDataFileName "examples" - let userGuidePath = examplePath "UserGuide.spthy" - csf12Path = examplePath "csf12" "*.spthy" - csf12Cmd = programName ++ " --prove -Ocase-studies +RTS -N -RTS " ++ csf12Path - csf12Cmd' = programName ++ " interactive +RTS -N -RTS " ++ csf12Path - separator = putStrLn $ replicate shortLineWidth '-' - putPath info path = putStrLn info >> putStrLn (" " ++ path ++ "\n") - separator - putPath "For example protocol models see" examplePath - putPath "Their syntax is explained in" userGuidePath - putPath "To run all case-studies from our CSF'12 submission, use" csf12Cmd - putPath "To construct their security proofs interactively, use" csf12Cmd' - putStrLn - "Note that the +RTS -N -RTS flags instruct the Haskell runtime system to\n\ - \use as many cores as your system has. This speeds-up some of the computations." - separator - exitFailure - where - ------------------------------------------------------------------------------- --- Main mode execution ------------------------------------------------------------------------------- +#ifdef NO_GUI +import qualified Main_NoGui as M +#else +import qualified Main_Full as M +#endif --- | Main function. main :: IO () -main = - withArguments mainMode selectMode - where - selectMode as = case findArg "mode" as of - Just "translate" -> translate as - Just "intruder" -> intruderVariants as - Just "interactive" -> interactive as - Just m -> error $ "main: unknown mode '" ++ m ++ "'" - Nothing -> error $ "main: no mode given" - --- shared support functions ---------------------------- - -renderDoc :: Isar.Doc -> String -renderDoc = Isar.renderStyle (Isar.style { Isar.lineLength = lineWidth }) - - ------------------------------------------------------------------------------- --- Intruder variants mode execution ------------------------------------------------------------------------------- - -intruderVariants :: Arguments -> IO () -intruderVariants as = do - ensureMaude as - hnd <- startMaude (maudePath as) dhMaudeSig - let thy = dhIntruderTheory hnd - thyString = renderDoc $ prettyOpenTheory thy - putStrLn thyString - writeThy thyString - where - -- output generation - -------------------- - - writeThy thyString = case optOutPath of - Just outPath -> writeFileWithDirs outPath thyString - Nothing -> return () - - -- Output file name, if output is desired. - optOutPath :: Maybe FilePath - optOutPath = - do outFile <- findArg "outFile" as - guard (outFile /= "") - return outFile - <|> - do outDir <- findArg "outDir" as - return $ outDir defaultIntrVariantsPath - -defaultIntrVariantsPath :: FilePath -defaultIntrVariantsPath = "intruder_variants_dh.spthy" - - ------------------------------------------------------------------------------- --- Theory loading: shared between interactive and batch mode ------------------------------------------------------------------------------- - -theoryLoadFlags :: [Flag Arguments] -theoryLoadFlags = - [ flagNone ["prove"] (addEmptyArg "addProofs") - "Attempt to prove all security properties" - - , flagOpt "dfs" ["stop-on-attack"] (updateArg "stopOnAttack") "DFS|BFS|NONE" - "How to search for attacks (default DFS)" - - -- , flagOpt "5" ["bound", "b"] (updateArg "bound") "INT" - -- "Bound the depth of the proofs" - - --, flagOpt "" ["intruder","i"] (updateArg "intruderVariants") "FILE" - -- "Cached intruder rules to use" - - , flagOpt "" ["defines","D"] (updateArg "defines") "STRING" - "Define flags for pseudo-preprocessor." - ] - -loadOpenThy :: Arguments -> FilePath -> IO OpenTheory -loadOpenThy = fst . loadThy - -loadClosedThy :: Arguments -> FilePath -> IO ClosedTheory -loadClosedThy = uncurry (>=>) . loadThy - -loadClosedWfThy :: Arguments -> FilePath -> IO ClosedTheory -loadClosedWfThy as file = do - thy <- loadOpen file - case checkWellformedness thy of - [] -> close thy - report -> error $ renderDoc $ prettyWfErrorReport report - where - (loadOpen, close) = loadThy as - -loadClosedThyString :: Arguments -> String -> IO ClosedTheory -loadClosedThyString = uncurry (>=>) . loadThyString - --- | Load an open/closed theory from a file. -loadThy :: Arguments -> (FilePath -> IO OpenTheory, OpenTheory -> IO ClosedTheory) -loadThy as = loadGenericThy (parseOpenTheory (defines as)) as - --- | Load an open/closed theory from a string. -loadThyString :: Arguments -> (String -> IO OpenTheory, OpenTheory -> IO ClosedTheory) -loadThyString as = loadGenericThy loader as - where - loader str = - case parseOpenTheoryString (defines as) str of - Right thy -> return thy - Left err -> error $ show err - --- | The defined pre-processor flags in the argument. -defines :: Arguments -> [String] -defines = findArg "defines" - --- | Load an open/closed theory given a loader function. -loadGenericThy :: (a -> IO OpenTheory) - -> Arguments - -> (a -> IO OpenTheory, OpenTheory -> IO ClosedTheory) -loadGenericThy loader as = - (loader, (closeThy as) <=< tryAddIntrVariants) - where - -- intruder variants - -------------------- - tryAddIntrVariants :: OpenTheory -> IO OpenTheory - tryAddIntrVariants thy0 = do - let msig = get (sigpMaudeSig . thySignature) thy0 - thy = addIntrRuleACs (subtermIntruderRules msig ++ specialIntruderRules) thy0 - if (enableDH msig) then - do variantsFile <- getDataFileName "intruder_variants_dh.spthy" - ifM (doesFileExist variantsFile) - (do intrVariants <- - get thyCache <$> parseOpenTheory (defines as) variantsFile - return $ addIntrRuleACs intrVariants thy - ) - (error $ "could not find intruder message deduction theory '" - ++ variantsFile ++ "'") - else return thy - --- | Close a theory according to arguments. -closeThy :: Arguments -> OpenTheory -> IO ClosedTheory -closeThy as = - fmap (proveTheory prover) . closeTheory (maudePath as) . wfCheck - where - -- handles to relevant arguments - -------------------------------- - proofBound = read <$> findArg "bound" as - requireProofs = argExists "addProofs" as - - stopOnAttack :: Maybe String - stopOnAttack = findArg "stopOnAttack" as - - -- wellformedness check - ----------------------- - wfCheck :: OpenTheory -> OpenTheory - wfCheck thy = - noteWellformedness - (checkWellformedness thy) thy - - -- protocol transformation - -------------------------- - prover :: Prover - prover - | requireProofs = cutAttack $ maybe id boundProver proofBound autoProver - | otherwise = mempty - where - cutAttack = mapProverProof $ case map toLower <$> stopOnAttack of - Nothing -> cutOnAttackDFS - Just "dfs" -> cutOnAttackDFS - Just "none" -> id - Just "bfs" -> cutOnAttackBFS - Just other -> error $ "unknown stop-on-attack method: " ++ other - ------------------------------------------------------------------------------- --- Tool paths (shared between interactive and batch mode) ------------------------------------------------------------------------------- - --- | Path to maude tool -maudePath :: Arguments -> FilePath -maudePath = fromMaybe "maude" . findArg "withMaude" - --- | Path to dot tool -dotPath :: Arguments -> FilePath -dotPath = fromMaybe "dot" . findArg "withDot" - ------------------------------------------------------------------------------- --- Interactive proof mode execution ------------------------------------------------------------------------------- - --- | Prove lemmas interactively. -interactive :: Arguments -> IO () -interactive as = case findArg "workDir" as of - Nothing -> errHelpExit "no working directory specified" - Just workDir0 -> do - -- determine working directory - wdIsFile <- doesFileExist workDir0 - let workDir | wdIsFile = takeDirectory workDir0 - | otherwise = workDir0 - wdIsDir <- doesDirectoryExist workDir - if wdIsDir - then do - -- process theories - ensureGraphVizDot as - ensureMaude as - putStrLn "" - port <- readPort - dataDir <- readDataDir - putStrLn $ intercalate "\n" - [ "The server is starting up on localhost with port " ++ show port ++ "." - , "Browse to http://localhost:" ++ show port ++ " once the server is ready." - , "" - , "Loading the security protocol theories '" ++ workDir "*.spthy" ++ "' ..." - ] - withWebUI workDir (argExists "loadstate" as) (argExists "autosave" as) - (loadClosedWfThy as) (loadClosedThyString as) (closeThy as) - (argExists "debug" as) (Just dataDir) (Warp.run port) - - else errHelpExit $ "directory '" ++ workDir ++ "' does not exist." - where - -- Datadir argument - readDataDir = - case findArg "datadir" as of - [d] -> return d - _ -> getDataDir - - -- Port argument - ---------------- - readPort = do - let port = findArg "port" as >>= fmap fst . listToMaybe . reads - when - (argExists "port" as && isNothing port) - (putStrLn $ "Unable to read port from argument `" - ++fromMaybe "" (findArg "port" as)++"'. Using default.") - return $ fromMaybe Web.Settings.defaultPort port - ------------------------------------------------------------------------------- --- Translate mode execution ------------------------------------------------------------------------------- - --- | Execute a translation. -translate :: Arguments -> IO () -translate as - | null inFiles = errHelpExit "no input files given" - | otherwise = do - ensureMaude as - putStrLn $ "" - summaries <- mapM processThy inFiles - putStrLn $ "" - putStrLn $ replicate shortLineWidth '=' - putStrLn $ "summary of processed files:" - putStrLn $ "" - putStrLn $ renderDoc $ Isar.vcat $ intersperse (Isar.text "") summaries - putStrLn $ "" - putStrLn $ replicate shortLineWidth '=' - where - -- handles to arguments - ----------------------- - inFiles = reverse $ findArg "inFile" as - - -- output generation - -------------------- - - dryRun = not (argExists "outFile" as || argExists "outDir" as) - - mkOutPath :: FilePath -- ^ Input file name. - -> FilePath -- ^ Output file name. - mkOutPath inFile = - fromMaybe (error "please specify an output file or directory") $ - do outFile <- findArg "outFile" as - guard (outFile /= "") - return outFile - <|> - do outDir <- findArg "outDir" as - return $ mkAutoPath outDir (takeBaseName inFile) - - -- automatically generate the filename for output - mkAutoPath :: FilePath -> String -> FilePath - mkAutoPath dir baseName - | argExists "html" as = dir baseName - | otherwise = dir addExtension (baseName ++ "_analyzed") "spthy" - - -- theory processing functions - ------------------------------ - - processThy :: FilePath -> IO (Isar.Doc) - processThy inFile - -- | argExists "html" as = - -- generateHtml inFile =<< loadClosedThy as inFile - | argExists "parseOnly" as = - out (const Isar.emptyDoc) prettyOpenTheory (loadOpenThy as inFile) - | otherwise = - out prettyClosedSummary prettyClosedTheory (loadClosedThy as inFile) - where - out :: (a -> Isar.Doc) -> (a -> Isar.Doc) -> IO a -> IO Isar.Doc - out summaryDoc fullDoc load = do - res <- try $ - if dryRun - then do writeWithSummary putStrLn "" - else do - putStrLn $ "" - putStrLn $ "analyzing: " ++ inFile - putStrLn $ "" - let outFile = mkOutPath inFile - summary <- writeWithSummary (writeFileWithDirs outFile) outFile - putStrLn $ replicate shortLineWidth '-' - putStrLn $ renderDoc summary - putStrLn $ "" - putStrLn $ replicate shortLineWidth '-' - return summary - case res of - Right x -> return x - Left x -> return $ Isar.vcat $ map Isar.text - [ "failed to analyze: " ++ inFile - , "" - , " exception: " ++ show (x :: IOException) - ] - where - writeWithSummary :: (String -> IO ()) -> FilePath -> IO Isar.Doc - writeWithSummary io outName = do - (thySummary, t) <- timed $ do - thy <- load - io $ renderDoc $ fullDoc thy - return $ summaryDoc thy - return $ Isar.vcat - [ Isar.text $ "analyzed: " ++ inFile - , Isar.text $ "" - , Isar.text $ " output: " ++ outName - , Isar.text $ " processing time: " ++ show t - , Isar.text $ "" - , Isar.nest 2 thySummary - ] - - {- TO BE REACTIVATED once infrastructure from interactive mode can be used - - -- static html generation - ------------------------- - - generateHtml :: FilePath -- ^ Input file - -> ClosedTheory -- ^ Theory to pretty print - -> IO () - generateHtml inFile thy = do - cmdLine <- getCommandLine - time <- getCurrentTime - cpu <- getCpuModel - template <- getHtmlTemplate - theoryToHtml $ GenerationInput { - giHeader = "Generated by " ++ htmlVersionStr - , giTime = time - , giSystem = cpu - , giInputFile = inFile - , giTemplate = template - , giOutDir = mkOutPath inFile - , giTheory = thy - , giCmdLine = cmdLine - , giCompress = not $ argExists "noCompress" as - } - - -} - ------------------------------------------------------------------------------- --- Utility functions ------------------------------------------------------------------------------- - --- | Write a file and ensure that its containing directory exists. -writeFileWithDirs :: FilePath -> String -> IO () -writeFileWithDirs file output = do - createDirectoryIfMissing True (takeDirectory file) - writeFile file output - --- | Get the string constituting the command line. -getCommandLine :: IO String -getCommandLine = do - arguments <- getArgs - return . concat . intersperse " " $ programName : arguments - --- | Read the cpu info using a call to cat /proc/cpuinfo -getCpuModel :: IO String -getCpuModel = - handle handler $ do - (_, info, _) <- readProcessWithExitCode "cat" ["/proc/cpuinfo"] [] - return $ maybe errMsg - (("Linux running on an "++) . drop 2 . dropWhile (/=':')) - (find (isPrefixOf "model name") $ lines info) - where - errMsg = "could not extract CPU model" - handler :: IOException -> IO String - handler _ = return errMsg - --- | Get the path to the Html template file. -getHtmlTemplate :: IO FilePath -getHtmlTemplate = getDataFileName "HTML_TEMPLATE" - - --- | Build the command line corresponding to a program arguments tuple. -commandLine :: String -> [String] -> String -commandLine prog args = concat $ intersperse " " $ prog : args - --- | Test if a process is executable and check its response. This is used to --- determine the versions and capabilities of tools that we depend on. -testProcess :: (String -> String -> Either String String) - -- ^ Analysis of stdout, stderr. Use 'Left' to report error. - -> String -- ^ Test description to display. - -> FilePath -- ^ Process to start - -> [String] -- ^ Arguments - -> String -- ^ Stdin - -> IO Bool -- ^ True, if test was successful -testProcess check testName prog args inp = do - putStr testName - hFlush stdout - handle handler $ do - (exitCode, out, err) <- readProcessWithExitCode prog args inp - let errMsg reason = do - putStrLn reason - putStrLn $ " command: " ++ commandLine prog args - putStrLn $ " stdin: " ++ inp - putStrLn $ " stdout: " ++ out - putStrLn $ " stderr: " ++ err - return False - - case exitCode of - ExitFailure code -> errMsg $ "failed with exit code " ++ show code - ExitSuccess -> - case check out err of - Left msg -> errMsg msg - Right msg -> do putStrLn msg - return True - where - handler :: IOException -> IO Bool - handler _ = do putStrLn "caught exception while executing:" - putStrLn $ commandLine prog args - putStrLn $ "with input: " ++ inp - return False - --- | Ensure a suitable version of the Graphviz dot tool is installed. -ensureGraphVizDot :: Arguments -> IO () -ensureGraphVizDot as = do - putStrLn $ "GraphViz tool: '" ++ dot ++ "'" - success <- testProcess check " checking version: " dot ["-V"] "" - unless success $ putStrLn errMsg - where - dot = dotPath as - check _ err - | "graphviz" `isInfixOf` map toLower err = Right $ init err ++ ". OK." - | otherwise = Left $ errMsg - errMsg = unlines - [ "WARNING:" - , "" - , " The dot tool seems not to be provided by Graphviz." - , " Graph generation might not work." - , " Please download an official version from:" - , " http://www.graphviz.org/" - ] - --- | Ensure a suitable version of Maude is installed. -ensureMaude :: Arguments -> IO () -ensureMaude as = do - putStrLn $ "maude tool: '" ++ maude ++ "'" - success <- testProcess check " checking version: " maude ["--version"] "" - unless success $ putStrLn $ errMsg "tool not found / does not work" - where - maude = maudePath as - check out _ - | filter (not . isSpace) out == "2.6" = Right "2.6. OK." - | otherwise = Left $ errMsg $ - " 'maude --version' returned wrong verison '" ++ out ++ "'" - - errMsg reason = unlines - [ "WARNING:" - , "" - , reason - , " " ++ programName ++ " will likely not work." - , " Please download 'Core Maude 2.6' from:" - , " http://maude.cs.uiuc.edu/download/" - ] +main = M.main diff --git a/src/Main/Console.hs b/src/Main/Console.hs new file mode 100644 --- /dev/null +++ b/src/Main/Console.hs @@ -0,0 +1,248 @@ +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Support for interaction with the console: argument parsing. +module Main.Console ( + + defaultMain + + -- * Static information about the Tamarin prover + , programName + + -- * Constructing interaction modes for Tamarin prover + , TamarinMode + , tamarinMode + + , helpAndExit + + -- * Argument parsing + , Arguments + , ArgKey + , ArgVal + + -- ** Setting arguments + , updateArg + , addEmptyArg + + , helpFlag + + -- ** Retrieving arguments + , getArg + , findArg + , argExists + + -- * Pretty printing and console output + , lineWidth + , shortLineWidth + + , renderDoc + ) where + +import Safe +import Data.Maybe +import Data.Version (showVersion) + +import Control.Monad + +import System.FilePath +import System.Console.CmdArgs.Explicit +import System.Console.CmdArgs.Text +import System.Exit + +import qualified Text.PrettyPrint.Class as PP + +import Paths_tamarin_prover + +------------------------------------------------------------------------------ +-- Static constants for the tamarin-prover +------------------------------------------------------------------------------ + +-- | Program name +programName :: String +programName = "tamarin-prover" + +-- | Version string +versionStr :: FilePath -- ^ Path to LICENCE file. + -> String +versionStr licensePath = unlines + [ concat + [ programName + , " " + , showVersion version + , ", (C) Benedikt Schmidt, Simon Meier, ETH Zurich 2010-2012" + ] + , "" + , "This program comes with ABSOLUTELY NO WARRANTY. It is free software, and you" + , "are welcome to redistribute it according to its LICENSE, see" + , "'" ++ licensePath ++ "'." + ] + +-- | Line width to use. +lineWidth :: Int +lineWidth = 110 + +shortLineWidth :: Int +shortLineWidth = 78 + + +------------------------------------------------------------------------------ +-- A simple generic representation of arguments +------------------------------------------------------------------------------ + +-- | A name of an argument. +type ArgKey = String + +-- | A value of an argument. +type ArgVal = String + +-- | It is most convenient to view arguments just as 'String' based key-value +-- pairs. If there are multiple values for the same key, then the left-most +-- one is preferred. +type Arguments = [(ArgKey,ArgVal)] + +-- | Does an argument exist. +argExists :: String -> Arguments -> Bool +argExists a = isJust . findArg a + +-- | Find the value(s) corresponding to the given key. +findArg :: MonadPlus m => ArgKey -> Arguments -> m ArgVal +findArg a' as = msum [ return v | (a,v) <- as, a == a' ] + +-- | Find the value corresponding to the given key. Throw an error if no value +-- exists. +getArg :: ArgKey -> Arguments -> ArgVal +getArg a = + fromMaybe (error $ "getArg: argument '" ++ a ++ "' not found") . findArg a + +-- | Add an argument to the from of the list of arguments. +addArg :: ArgKey -> ArgVal -> Arguments -> Arguments +addArg a v = ((a,v):) + +-- | Add an argument with the empty string as the value. +addEmptyArg :: String -> Arguments -> Arguments +addEmptyArg a = addArg a "" + +-- | Update an argument. +updateArg :: ArgKey -> ArgVal -> Arguments -> Either a Arguments +updateArg a v = Right . addArg a v + +-- | Add the help flag. +helpFlag :: Flag Arguments +helpFlag = flagHelpSimple (addEmptyArg "help") + + +------------------------------------------------------------------------------ +-- Modes for using the Tamarin prover +------------------------------------------------------------------------------ + +-- | A representation of an interaction mode with the Tamarin prover. +data TamarinMode = TamarinMode + { tmName :: String + , tmCmdArgsMode :: Mode Arguments + -- ^ Run is given a reference to the mode. This enables changing the + -- static information of a mode and keeping the same 'run' function. + -- We use this for implementing the 'main' mode. + , tmRun :: TamarinMode -> Arguments -> IO () + , tmIsMainMode :: Bool + } + +-- | Smart constructor for a 'TamarinMode'. +tamarinMode :: String -> Help + -> (Mode Arguments -> Mode Arguments) -- ^ Changes to default mode. + -> (TamarinMode -> Arguments -> IO ()) + -> TamarinMode +tamarinMode name help adaptMode run0 = TamarinMode + { tmName = name + , tmCmdArgsMode = adaptMode $ Mode + { modeGroupModes = toGroup [] + , modeNames = [name] + , modeValue = [] + , modeCheck = updateArg "mode" name + , modeReform = const Nothing-- no reform possibility + , modeHelp = help + , modeHelpSuffix = [] + , modeArgs = ([], Nothing) -- no positional arguments + , modeGroupFlags = toGroup [] -- no flags + } + , tmRun = run + , tmIsMainMode = False + } + where + run thisMode as + | argExists "help" as = helpAndExit thisMode Nothing + | argExists "version" as = do licensePath <- getDataFileName "LICENSE" + putStrLn $ versionStr licensePath + | otherwise = run0 thisMode as + +-- | Disply help message of a tamarin mode and exit. +helpAndExit :: TamarinMode -> Maybe String -> IO () +helpAndExit tmode mayMsg = do + putStrLn $ showText (Wrap lineWidth) + $ helpText header HelpFormatOne (tmCmdArgsMode tmode) + -- output example info + when (tmIsMainMode tmode) $ do + examplePath <- getDataFileName "examples" + manualPath <- getDataFileName "doc/MANUAL" + let tutorialPath = examplePath "stable" "Tutorial.spthy" + csf12Path = examplePath "csf12" "*.spthy" + csf12Cmd = programName ++ " --prove -Ocase-studies +RTS -N -RTS " ++ csf12Path + csf12Cmd' = programName ++ " interactive +RTS -N -RTS " ++ csf12Path + separator = replicate shortLineWidth '-' + e info paths = info ++ concatMap ("\n " ++) paths ++ "\n" + putStrLn $ unlines + [ separator + , e "For example protocol models see:" [examplePath] + , e "A tutorial and the user manul are found at" [tutorialPath, manualPath] + , e "To run all case-studies from our CSF'12 submission, use" [csf12Cmd] + , e "To construct their security proofs interactively, use" [csf12Cmd'] + , "Note that the +RTS -N -RTS flags instruct the Haskell runtime system to" + , "use as many cores as your system has. This speeds-up some of the computations." + , separator + ] + end + where + (header, end) = case mayMsg of + Nothing -> ([], return ()) + Just msg -> (["error: " ++ msg], exitFailure) + +-- | Main function. +defaultMain :: TamarinMode -> [TamarinMode] -> IO () +defaultMain firstMode otherModes = do + as <- processArgs $ tmCmdArgsMode mainMode + case findArg "mode" as of + Nothing -> error $ "defaultMain: impossible - mode not set" + Just name -> headNote "defaultMain: impossible - no mode found" $ do + tmode <- (mainMode : otherModes) + guard (tmName tmode == name) + return $ tmRun tmode tmode as + where + mainMode = firstMode + { tmName = programName + , tmCmdArgsMode = (tmCmdArgsMode firstMode) + { modeNames = [programName] + , modeCheck = updateArg "mode" programName + , modeGroupModes = toGroup (map tmCmdArgsMode $ otherModes) + , modeGroupFlags = (modeGroupFlags $ tmCmdArgsMode firstMode) + { groupNamed = + [ ("About" + , [ helpFlag + , flagVersion (addEmptyArg "version") + ] ) + ] + } + } + , tmIsMainMode = True + } + + +------------------------------------------------------------------------------ +-- Pretty printing +------------------------------------------------------------------------------ + +-- | Render a pretty-printing document. +renderDoc :: PP.Doc -> String +renderDoc = PP.renderStyle (PP.defaultStyle { PP.lineLength = lineWidth }) diff --git a/src/Main/Environment.hs b/src/Main/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Main/Environment.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Helpers for inspecting the environment of the Tamarin prover. +module Main.Environment where + +import Data.List +import Data.Char (isSpace, toLower) +import Data.Maybe (fromMaybe) + +import Control.Exception as E + +import System.Console.CmdArgs.Explicit +import System.Exit +import System.Environment +import System.IO +import System.Process + +import Paths_tamarin_prover + +import Main.Console + +------------------------------------------------------------------------------ +-- Retrieving the paths to required tools. +------------------------------------------------------------------------------ + +-- | Flags for handing over the path to the maude and 'dot' tool. +toolFlags :: [Flag Arguments] +toolFlags = + [ flagOpt "dot" ["with-dot"] (updateArg "withDot") "FILE" "Path to GraphViz 'dot' tool" + , flagOpt "maude" ["with-maude"] (updateArg "withMaude") "FILE" "Path to 'maude' rewriting tool" + ] + +-- | Path to maude tool +maudePath :: Arguments -> FilePath +maudePath = fromMaybe "maude" . findArg "withMaude" + +-- | Path to dot tool +dotPath :: Arguments -> FilePath +dotPath = fromMaybe "dot" . findArg "withDot" + + +------------------------------------------------------------------------------ +-- Inspecting the environment +------------------------------------------------------------------------------ + +-- | Get the string constituting the command line. +getCommandLine :: IO String +getCommandLine = do + arguments <- getArgs + return . concat . intersperse " " $ programName : arguments + +-- | Read the cpu info using a call to cat /proc/cpuinfo +getCpuModel :: IO String +getCpuModel = + handle handler $ do + (_, info, _) <- readProcessWithExitCode "cat" ["/proc/cpuinfo"] [] + return $ maybe errMsg + (("Linux running on an "++) . drop 2 . dropWhile (/=':')) + (find (isPrefixOf "model name") $ lines info) + where + errMsg = "could not extract CPU model" + handler :: IOException -> IO String + handler _ = return errMsg + +-- | Get the path to the Html template file. +getHtmlTemplate :: IO FilePath +getHtmlTemplate = getDataFileName "HTML_TEMPLATE" + + +-- | Build the command line corresponding to a program arguments tuple. +commandLine :: String -> [String] -> String +commandLine prog args = concat $ intersperse " " $ prog : args + +-- | Test if a process is executable and check its response. This is used to +-- determine the versions and capabilities of tools that we depend on. +testProcess :: (String -> String -> Either String String, String) + -- ^ Analysis of stdout, stderr. Use 'Left' to report error. + -> String -- ^ Test description to display. + -> FilePath -- ^ Process to start + -> [String] -- ^ Arguments + -> String -- ^ Stdin + -> IO Bool -- ^ True, if test was successful +testProcess (check, defaultMsg) testName prog args inp = do + putStr testName + hFlush stdout + handle handler $ do + (exitCode, out, err) <- readProcessWithExitCode prog args inp + let errMsg reason = do + putStrLn reason + putStrLn $ "Detailed results from testing '" ++ prog ++ "'" + putStrLn $ " command: " ++ commandLine prog args + putStrLn $ " stdin: " ++ inp + putStrLn $ " stdout: " ++ out + putStrLn $ " stderr: " ++ err + return False + + case exitCode of + ExitFailure code -> errMsg $ + "failed with exit code " ++ show code ++ "\n\n" ++ defaultMsg + ExitSuccess -> + case check out err of + Left msg -> errMsg msg + Right msg -> do putStrLn msg + return True + where + handler :: IOException -> IO Bool + handler _ = do putStrLn "caught exception while executing:" + putStrLn $ commandLine prog args + putStrLn $ "with input: " ++ inp + return False + +-- | Ensure a suitable version of the Graphviz dot tool is installed. +ensureGraphVizDot :: Arguments -> IO Bool +ensureGraphVizDot as = do + putStrLn $ "GraphViz tool: '" ++ dot ++ "'" + testProcess (check, errMsg) " checking version: " dot ["-V"] "" + where + dot = dotPath as + check _ err + | "graphviz" `isInfixOf` map toLower err = Right $ init err ++ ". OK." + | otherwise = Left $ errMsg + errMsg = unlines + [ "WARNING:" + , "" + , " The dot tool seems not to be provided by Graphviz." + , " Graph generation might not work." + , " Please download an official version from:" + , " http://www.graphviz.org/" + ] + +-- | Ensure a suitable version of Maude is installed. +ensureMaude :: Arguments -> IO Bool +ensureMaude as = do + putStrLn $ "maude tool: '" ++ maude ++ "'" + testProcess (check, errMsg') " checking version: " maude ["--version"] "" + where + maude = maudePath as + check out _ + | filter (not . isSpace) out == "2.6" = Right "2.6. OK." + | otherwise = Left $ errMsg $ + " 'maude --version' returned wrong verison '" ++ out ++ "'" + + errMsg' = errMsg $ "'" ++ maude ++ "' executable not found / does not work" + errMsg reason = unlines + [ "WARNING:" + , "" + , reason + , " " ++ programName ++ " will likely not work." + , " Please download 'Core Maude 2.6' from:" + , " http://maude.cs.uiuc.edu/download/" + ] diff --git a/src/Main/Mode/Batch.hs b/src/Main/Mode/Batch.hs new file mode 100644 --- /dev/null +++ b/src/Main/Mode/Batch.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Main module for the Tamarin prover. +module Main.Mode.Batch ( + batchMode + ) where + +import Data.List +import Data.Maybe +import Control.Basics +import System.Console.CmdArgs.Explicit as CmdArgs +import System.FilePath +import System.Timing (timed) + +import qualified Text.PrettyPrint.Class as Pretty + +import Theory + +import Main.Utils +import Main.Console +import Main.Environment +import Main.TheoryLoader + + +-- | Batch processing mode. +batchMode :: TamarinMode +batchMode = tamarinMode + "batch" + "Security protocol analysis and verification." + setupFlags + run + where + setupFlags defaultMode = defaultMode + { modeArgs = ([], Just $ flagArg (updateArg "inFile") "FILES") + , modeGroupFlags = Group + { groupUnnamed = + theoryLoadFlags ++ + -- [ flagNone ["html"] (addEmptyArg "html") + -- "generate HTML visualization of proofs" + + [ flagNone ["no-compress"] (addEmptyArg "noCompress") + "Do not use compressed sequent visualization" + + , flagNone ["parse-only"] (addEmptyArg "parseOnly") + "Just parse the input file and pretty print it as-is" + ] ++ + outputFlags ++ + toolFlags + , groupHidden = [] + , groupNamed = [] + } + } + + outputFlags = + [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file" + , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR" "Output directory" + ] + +-- | Process a theory file. +run :: TamarinMode -> Arguments -> IO () +run thisMode as + | null inFiles = helpAndExit thisMode (Just "no input files given") + | otherwise = do + _ <- ensureMaude as + putStrLn $ "" + summaries <- mapM processThy $ inFiles + putStrLn $ "" + putStrLn $ replicate 78 '=' + putStrLn $ "summary of summaries:" + putStrLn $ "" + putStrLn $ renderDoc $ Pretty.vcat $ intersperse (Pretty.text "") summaries + putStrLn $ "" + putStrLn $ replicate 78 '=' + where + -- handles to arguments + ----------------------- + inFiles = reverse $ findArg "inFile" as + + -- output generation + -------------------- + + dryRun = not (argExists "outFile" as || argExists "outDir" as) + + mkOutPath :: FilePath -- ^ Input file name. + -> FilePath -- ^ Output file name. + mkOutPath inFile = + fromMaybe (error "please specify an output file or directory") $ + do outFile <- findArg "outFile" as + guard (outFile /= "") + return outFile + <|> + do outDir <- findArg "outDir" as + return $ mkAutoPath outDir (takeBaseName inFile) + + -- automatically generate the filename for output + mkAutoPath :: FilePath -> String -> FilePath + mkAutoPath dir baseName + | argExists "html" as = dir baseName + | otherwise = dir addExtension (baseName ++ "_analyzed") "spthy" + + -- theory processing functions + ------------------------------ + + processThy :: FilePath -> IO (Pretty.Doc) + processThy inFile + -- | argExists "html" as = + -- generateHtml inFile =<< loadClosedThy as inFile + | argExists "parseOnly" as = + out (const Pretty.emptyDoc) prettyOpenTheory (loadOpenThy as inFile) + | otherwise = + out prettyClosedSummary prettyClosedTheory (loadClosedThy as inFile) + where + ppAnalyzed = Pretty.text $ "analyzed: " ++ inFile + + out :: (a -> Pretty.Doc) -> (a -> Pretty.Doc) -> IO a -> IO Pretty.Doc + out summaryDoc fullDoc load + | dryRun = do + thy <- load + putStrLn $ renderDoc $ fullDoc thy + return $ ppAnalyzed Pretty.$--$ Pretty.nest 2 (summaryDoc thy) + | otherwise = do + putStrLn $ "" + putStrLn $ "analyzing: " ++ inFile + putStrLn $ "" + let outFile = mkOutPath inFile + (thySummary, t) <- timed $ do + thy <- load + writeFileWithDirs outFile $ renderDoc $ fullDoc thy + return $ summaryDoc thy + let summary = Pretty.vcat + [ ppAnalyzed + , Pretty.text $ "" + , Pretty.text $ " output: " ++ outFile + , Pretty.text $ " processing time: " ++ show t + , Pretty.text $ "" + , Pretty.nest 2 thySummary + ] + putStrLn $ replicate 78 '-' + putStrLn $ renderDoc summary + putStrLn $ "" + putStrLn $ replicate 78 '-' + return summary + + {- TO BE REACTIVATED once infrastructure from interactive mode can be used + + -- static html generation + ------------------------- + + generateHtml :: FilePath -- ^ Input file + -> ClosedTheory -- ^ Theory to pretty print + -> IO () + generateHtml inFile thy = do + cmdLine <- getCommandLine + time <- getCurrentTime + cpu <- getCpuModel + template <- getHtmlTemplate + theoryToHtml $ GenerationInput { + giHeader = "Generated by " ++ htmlVersionStr + , giTime = time + , giSystem = cpu + , giInputFile = inFile + , giTemplate = template + , giOutDir = mkOutPath inFile + , giTheory = thy + , giCmdLine = cmdLine + , giCompress = not $ argExists "noCompress" as + } + + -} diff --git a/src/Main/Mode/Interactive.hs b/src/Main/Mode/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/Main/Mode/Interactive.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Main module for the Tamarin prover. +module Main.Mode.Interactive ( + interactiveMode + ) where + +import Data.List +import Data.Maybe +import Control.Basics +import System.Console.CmdArgs.Explicit as CmdArgs +import System.FilePath +import System.Directory (doesFileExist, doesDirectoryExist) + +import Web.Dispatch +import qualified Web.Settings +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Handler.Warp (defaultSettings, settingsHost + , settingsPort, HostPreference(Host)) + +import Main.Console +import Main.Environment +import Main.TheoryLoader + +import Paths_tamarin_prover (getDataDir) + + +-- | Batch processing mode. +interactiveMode :: TamarinMode +interactiveMode = tamarinMode + "interactive" + "Start a web-server to construct proofs interactively." + setupFlags + run + where + setupFlags defaultMode = defaultMode + { modeArgs = ([], Just $ flagArg (updateArg "workDir") "WORKDIR") + , modeCheck = updateArg "mode" "interactive" + , modeGroupFlags = Group interactiveFlags [] [("About", [helpFlag])] + } + + interactiveFlags = + [ flagOpt "" ["port","p"] (updateArg "port") "PORT" "Port to listen on" + -- , flagOpt "" ["datadir"] (updateArg "datadir") "DATADIR" "Directory with data" + , flagNone ["debug"] (addEmptyArg "debug") "Show server debugging output" + -- , flagNone ["autosave"] (addEmptyArg "autosave") "Automatically save proof state" + -- , flagNone ["loadstate"] (addEmptyArg "loadstate") "Load proof state if present" + ] ++ + theoryLoadFlags ++ + toolFlags + + + +-- | Start the interactive theorem proving mode. +run :: TamarinMode -> Arguments -> IO () +run thisMode as = case findArg "workDir" as of + Nothing -> helpAndExit thisMode + (Just "no working directory specified") + Just workDir0 -> do + -- determine working directory + wdIsFile <- doesFileExist workDir0 + let workDir | wdIsFile = takeDirectory workDir0 + | otherwise = workDir0 + wdIsDir <- doesDirectoryExist workDir + if wdIsDir + then do + -- process theories + _ <- ensureGraphVizDot as + _ <- ensureMaude as + putStrLn "" + port <- readPort + dataDir <- readDataDir + let serverUrl = "http://127.0.0.1:" ++ show port + putStrLn $ intercalate "\n" + [ "The server is starting up on port " ++ show port ++ "." + , "Browse to " ++ serverUrl ++ " once the server is ready." + , "" + , "Loading the security protocol theories '" ++ workDir "*.spthy" ++ "' ..." + ] + withWebUI + ("Finished loading theories ... server ready at \n\n " ++ serverUrl ++ "\n") + workDir (argExists "loadstate" as) (argExists "autosave" as) + (loadClosedWfThy as) (loadClosedThyString as) (closeThy as) + (argExists "debug" as) dataDir + (Warp.runSettings + (defaultSettings { settingsHost = Host "127.0.0.1", + settingsPort = port})) + else + helpAndExit thisMode + (Just $ "directory '" ++ workDir ++ "' does not exist.") + where + -- Datadir argument + readDataDir = + case findArg "datadir" as of + [d] -> return d + _ -> getDataDir + + -- Port argument + ---------------- + readPort = do + let port = findArg "port" as >>= fmap fst . listToMaybe . reads + when + (argExists "port" as && isNothing port) + (putStrLn $ "Unable to read port from argument `" + ++fromMaybe "" (findArg "port" as)++"'. Using default.") + return $ fromMaybe Web.Settings.defaultPort port diff --git a/src/Main/Mode/Intruder.hs b/src/Main/Mode/Intruder.hs new file mode 100644 --- /dev/null +++ b/src/Main/Mode/Intruder.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Main module for the Tamarin prover. +module Main.Mode.Intruder ( + intruderMode + ) where + +import Control.Basics +import Control.Monad.Reader + +import System.Console.CmdArgs.Explicit as CmdArgs +import System.FilePath + +import Theory + +import Main.Console +import Main.Environment +import Main.TheoryLoader (intruderVariantsFile) +import Main.Utils + + +intruderMode :: TamarinMode +intruderMode = tamarinMode + "variants" + "Compute the variants of the intruder rules for DH-exponentiation." + setupFlags + run + where + setupFlags defaultMode = defaultMode + { modeArgs = ([], Nothing ) -- no positional argumants + , modeGroupFlags = Group outputFlags [] [("About", [helpFlag])] + } + + outputFlags = + [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file" + , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR" "Output directory" + ] + +-- | Compute the intruder variants. +run :: TamarinMode -> Arguments -> IO () +run _thisMode as = do + _ <- ensureMaude as + hnd <- startMaude (maudePath as) dhMaudeSig + let rules = dhIntruderRules `runReader` hnd + rulesString = renderDoc $ prettyIntruderVariants rules + putStrLn rulesString + writeRules rulesString + where + -- output generation + -------------------- + + writeRules rulesString = case optOutPath of + Just outPath -> writeFileWithDirs outPath rulesString + Nothing -> return () + + -- Output file name, if output is desired. + optOutPath :: Maybe FilePath + optOutPath = + do outFile <- findArg "outFile" as + guard (outFile /= "") + return outFile + <|> + do outDir <- findArg "outDir" as + return $ outDir intruderVariantsFile diff --git a/src/Main/Mode/Test.hs b/src/Main/Mode/Test.hs new file mode 100644 --- /dev/null +++ b/src/Main/Mode/Test.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Self-test mode for the Tamarin prover. +module Main.Mode.Test ( + testMode + ) where + +import System.Console.CmdArgs.Explicit as CmdArgs +import System.Exit +import Test.HUnit (Counts(..)) + +import Main.Console +import Main.Environment + +import qualified Term.UnitTests as TestTerm (main) + + +-- | Self-test mode. +testMode :: TamarinMode +testMode = tamarinMode + "test" + ("Self-test the " ++ programName ++ " installation.") + setupFlags + run + where + setupFlags defaultMode = defaultMode + { modeArgs = ([], Just $ flagArg (updateArg "inFile") "FILES") + , modeGroupFlags = Group + { groupUnnamed = toolFlags + , groupHidden = [] + , groupNamed = [("About", [helpFlag])] + } + } + +-- | Run the self-test. +run :: TamarinMode -> Arguments -> IO () +run _thisMode as = do + putStrLn $ "Self-testing the " ++ programName ++ " installation." + nextTopic "Testing the availability of the required tools" + successMaude <- ensureMaude as +#ifndef NO_GUI + putStrLn "" + successGraphVizDot <- ensureGraphVizDot as +#else + let successGraphVizDot = True +#endif + nextTopic "Testing the unification infrastructure" + Counts _ _ termErrs termFails <- TestTerm.main (maudePath as) + let successTerm = termErrs == 0 && termFails == 0 + success = and [successMaude, successGraphVizDot, successTerm] + + -- FIXME: Implement regression testing. + -- + nextTopic "TEST SUMMARY" + if success + then do putStrLn $ "All tests successful." + putStrLn $ "The " ++ programName ++ " should work as intended." + putStrLn $ "\n :-) happy proving (-:\n" + exitSuccess + else do putStrLn $ "\nWARNING: Some tests failed." + putStrLn $ "The " ++ programName ++ " might NOT WORK AS INTENDED.\n" + exitFailure + where + nextTopic msg = putStrLn $ "\n*** " ++ msg ++ " ***" diff --git a/src/Main/TheoryLoader.hs b/src/Main/TheoryLoader.hs new file mode 100644 --- /dev/null +++ b/src/Main/TheoryLoader.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Theory loading infrastructure. +module Main.TheoryLoader ( + -- * Static theory loading settings + intruderVariantsFile + , theoryLoadFlags + + -- ** Loading open theories + , loadOpenThy + + -- ** Loading and closing theories + , loadClosedThy + , loadClosedWfThy + , loadClosedThyString + + , closeThy + + ) where + +import Prelude hiding (id, (.)) + +import Data.Monoid +import Data.Char (toLower) +import Data.Label + +import Control.Basics +import Control.Category + +import System.Console.CmdArgs.Explicit +import System.Directory + +import Extension.Prelude + +import Theory +import Theory.Parser +import Theory.Wellformedness +import Theory.AbstractInterpretation (EvaluationStyle(..)) + +import Main.Console +import Main.Environment + +import Paths_tamarin_prover (getDataFileName) + + +------------------------------------------------------------------------------ +-- Theory loading: shared between interactive and batch mode +------------------------------------------------------------------------------ + +-- | The name of the intruder variants file. +intruderVariantsFile :: FilePath +intruderVariantsFile = "intruder_variants_dh.spthy" + + +-- | Flags for loading a theory. +theoryLoadFlags :: [Flag Arguments] +theoryLoadFlags = + [ flagNone ["prove"] (addEmptyArg "addProofs") + "Attempt to prove all security properties" + + , flagOpt "dfs" ["stop-on-trace"] (updateArg "stopOnTrace") "DFS|BFS|NONE" + "How to search for traces (default DFS)" + + , flagOpt "5" ["bound", "b"] (updateArg "bound") "INT" + "Bound the depth of the proofs" + + --, flagOpt "" ["intruder","i"] (updateArg "intruderVariants") "FILE" + -- "Cached intruder rules to use" + + , flagOpt "summary" ["partial-evaluation"] (updateArg "partialEvaluation") + "SUMMARY|VERBOSE" + "Partially evaluate multiset rewriting system" + + , flagOpt "" ["defines","D"] (updateArg "defines") "STRING" + "Define flags for pseudo-preprocessor." + ] + +loadOpenThy :: Arguments -> FilePath -> IO OpenTheory +loadOpenThy = fst . loadThy + +loadClosedThy :: Arguments -> FilePath -> IO ClosedTheory +loadClosedThy = uncurry (>=>) . loadThy + +loadClosedWfThy :: Arguments -> FilePath -> IO ClosedTheory +loadClosedWfThy as file = do + thy <- loadOpen file + case checkWellformedness thy of + [] -> close thy + report -> do + putStrLn $ "WARNING: ignoring the following errors" + putStrLn $ renderDoc $ prettyWfErrorReport report + close thy + -- report -> error $ renderDoc $ prettyWfErrorReport report + where + (loadOpen, close) = loadThy as + +loadClosedThyString :: Arguments -> String -> IO ClosedTheory +loadClosedThyString = uncurry (>=>) . loadThyString + +-- | Load an open/closed theory from a file. +loadThy :: Arguments -> (FilePath -> IO OpenTheory, OpenTheory -> IO ClosedTheory) +loadThy as = loadGenericThy (parseOpenTheory (defines as)) as + +-- | Load an open/closed theory from a string. +loadThyString :: Arguments -> (String -> IO OpenTheory, OpenTheory -> IO ClosedTheory) +loadThyString as = loadGenericThy loader as + where + loader str = + case parseOpenTheoryString (defines as) str of + Right thy -> return thy + Left err -> error $ show err + +-- | The defined pre-processor flags in the argument. +defines :: Arguments -> [String] +defines = findArg "defines" + +-- | Load an open/closed theory given a loader function. +loadGenericThy :: (a -> IO OpenTheory) + -> Arguments + -> (a -> IO OpenTheory, OpenTheory -> IO ClosedTheory) +loadGenericThy loader as = + (loader, (closeThy as) <=< tryAddIntrVariants) + where + -- intruder variants + -------------------- + tryAddIntrVariants :: OpenTheory -> IO OpenTheory + tryAddIntrVariants thy0 = do + let msig = get (sigpMaudeSig . thySignature) thy0 + thy = addIntrRuleACs (subtermIntruderRules msig ++ specialIntruderRules) thy0 + if (enableDH msig) then + do variantsFile <- getDataFileName intruderVariantsFile + ifM (doesFileExist variantsFile) + (do intrVariants <- parseIntruderRulesDH variantsFile + return $ addIntrRuleACs intrVariants thy + ) + (error $ "could not find intruder message deduction theory '" + ++ variantsFile ++ "'") + else return thy + +-- | Close a theory according to arguments. +closeThy :: Arguments -> OpenTheory -> IO ClosedTheory +closeThy as = + fmap (proveTheory prover . partialEvaluation) + . closeTheory (maudePath as) + -- FIXME: wf-check is at the wrong position here. Needs to be more + -- fine-grained. + . wfCheck + where + -- handles to relevant arguments + -------------------------------- + proofBound = read <$> findArg "bound" as + requireProofs = argExists "addProofs" as + + stopOnTrace :: Maybe String + stopOnTrace = findArg "stopOnTrace" as + + -- apply partial application + ---------------------------- + partialEvaluation = case map toLower <$> findArg "partialEvaluation" as of + Just "verbose" -> applyPartialEvaluation Tracing + Just _ -> applyPartialEvaluation Summary + _ -> id + + -- wellformedness check + ----------------------- + wfCheck :: OpenTheory -> OpenTheory + wfCheck thy = + noteWellformedness + (checkWellformedness thy) thy + + -- protocol transformation + -------------------------- + prover :: Prover + prover + | requireProofs = cutAttack $ maybe id boundProver proofBound autoProver + | otherwise = mempty + where + cutAttack = mapProverProof $ case map toLower <$> stopOnTrace of + Nothing -> cutOnAttackDFS + Just "dfs" -> cutOnAttackDFS + Just "none" -> id + Just "bfs" -> cutOnAttackBFS + Just other -> error $ "unknown stop-on-trace method: " ++ other + diff --git a/src/Main/Utils.hs b/src/Main/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Main/Utils.hs @@ -0,0 +1,28 @@ +-- | +-- Copyright : (c) 2012 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- +-- Various utility functions for interacting with the user. +module Main.Utils ( + -- * File handling + writeFileWithDirs + + ) where + + +import System.FilePath +import System.Directory + + +------------------------------------------------------------------------------ +-- File Handling +------------------------------------------------------------------------------ + +-- | Write a file and ensure that its containing directory exists. +writeFileWithDirs :: FilePath -> String -> IO () +writeFileWithDirs file output = do + createDirectoryIfMissing True (takeDirectory file) + writeFile file output + diff --git a/src/Main_Full.hs b/src/Main_Full.hs new file mode 100644 --- /dev/null +++ b/src/Main_Full.hs @@ -0,0 +1,18 @@ +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Main module for the Tamarin prover without a GUI. +module Main_Full where + +import Main.Console (defaultMain) +import Main.Mode.Batch (batchMode) +import Main.Mode.Intruder (intruderMode) +import Main.Mode.Interactive (interactiveMode) +import Main.Mode.Test (testMode) + +main :: IO () +main = defaultMain batchMode [interactiveMode, intruderMode, testMode] diff --git a/src/Main_NoGui.hs b/src/Main_NoGui.hs new file mode 100644 --- /dev/null +++ b/src/Main_NoGui.hs @@ -0,0 +1,17 @@ +-- | +-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : GHC only +-- +-- Main module for the Tamarin prover without a GUI +module Main_NoGui where + +import Main.Console (defaultMain) +import Main.Mode.Batch (batchMode) +import Main.Mode.Intruder (intruderMode) +import Main.Mode.Test (testMode) + +main :: IO () +main = defaultMain batchMode [intruderMode, testMode] diff --git a/src/Theory.hs b/src/Theory.hs --- a/src/Theory.hs +++ b/src/Theory.hs @@ -11,8 +11,10 @@ module Theory ( -- * Lemmas LemmaAttribute(..) - , Lemma(..) + , TraceQuantifier(..) + , Lemma , lName + , lTraceQuantifier , lFormulaE , lFormulaAC , lAttributes @@ -27,6 +29,7 @@ , thySignature , thyCache , thyItems + , theoryRules , addLemma , removeLemma , lookupLemma @@ -38,9 +41,9 @@ -- ** Open theories , OpenTheory , defaultOpenTheory - , dhIntruderTheory , addProtoRule , addIntrRuleACs + , applyPartialEvaluation -- ** Closed theories , ClosedTheory @@ -76,6 +79,9 @@ , prettyClosedSummary + , prettyIntruderVariants + , prettyTraceQuantifier + -- * Convenience exports , module Theory.Proof , module Theory.IntruderRules @@ -103,13 +109,13 @@ import qualified Extension.Data.Label as L import Extension.Data.Label hiding (get) -import Text.Isar - import Theory.Pretty import Theory.Rule +import Theory.RuleSet import Theory.RuleVariants import Theory.IntruderRules import Theory.Proof +import Theory.AbstractInterpretation ------------------------------------------------------------------------------ @@ -153,7 +159,7 @@ { _cprRuleE :: ProtoRuleE -- original rule modulo E , _cprRuleAC :: ProtoRuleAC -- variant modulo AC } - deriving( Show ) + deriving( Eq, Ord, Show ) type OpenRuleCache = [IntrRuleAC] @@ -203,7 +209,8 @@ closeRuleCache typingAsms sig protoRules intrRulesAC = ClosedRuleCache classifiedRules untypedCaseDists typedCaseDists where - ctxt0 = ProofContext sig classifiedRules [] + ctxt0 = ProofContext sig classifiedRules UntypedCaseDist [] AvoidInduction + (error "closeRuleCache: trace quantifier should not matter here") -- precomputing the case distinctions untypedCaseDists = precomputeCaseDistinctions ctxt0 [] typedCaseDists = @@ -215,18 +222,14 @@ anyOf ps = partition (\x -> any ($ x) ps) - (nonProto, proto) = - anyOf [ isDestrRule, isConstrRule , isFreshRule, isIRecvRule] rulesAC - (spec, nonSpec) = anyOf [isIRecvRule, isFreshRule] nonProto - (constr, destr) = anyOf [isConstrRule] nonSpec - -- FIXME: Learn, knows, fresh, etc. are special rules + (nonProto, proto) = anyOf [isDestrRule, isConstrRule] rulesAC + (constr, destr) = anyOf [isConstrRule] nonProto -- and sort them into ClassifiedRules datastructure for later use in proofs classifiedRules = ClassifiedRules { _crConstruct = constr , _crDestruct = destr , _crProtocol = proto - , _crSpecial = spec } @@ -235,21 +238,28 @@ -- Lemmas ------------------------------------------------------------------------------ +-- | An attribute for a 'Lemma'. data LemmaAttribute = TypingLemma | ReuseLemma + | InvariantLemma deriving( Eq, Ord, Show ) +-- | A 'TraceQuantifier' stating whether we check satisfiability of validity. +data TraceQuantifier = ExistsTrace | AllTraces + deriving( Eq, Ord, Show ) + -- | A lemma describes a property that holds in the context of a theory -- together with a proof of its correctness. data Lemma p = Lemma - { _lName :: String - , _lFormulaE :: FormulaE - , _lFormulaAC :: Maybe FormulaAC - , _lAttributes :: [LemmaAttribute] - , _lProof :: p + { _lName :: String + , _lTraceQuantifier :: TraceQuantifier + , _lFormulaE :: FormulaE + , _lFormulaAC :: Maybe FormulaAC + , _lAttributes :: [LemmaAttribute] + , _lProof :: p } - deriving( Show ) + deriving( Eq, Ord, Show ) $(mkLabels [''Lemma]) @@ -258,31 +268,47 @@ ------------ instance Functor Lemma where - fmap f (Lemma n fE fAC atts prf) = Lemma n fE fAC atts (f prf) + fmap f (Lemma n qua fE fAC atts prf) = Lemma n qua fE fAC atts (f prf) instance Foldable Lemma where foldMap f = f . L.get lProof instance Traversable Lemma where - traverse f (Lemma n fE fAC atts prf) = Lemma n fE fAC atts <$> f prf + traverse f (Lemma n qua fE fAC atts prf) = Lemma n qua fE fAC atts <$> f prf +-- Lemma queries +---------------------------------- + +-- | Convert a trace quantifier to a sequent trace quantifier. +toSequentTraceQuantifier :: TraceQuantifier -> SequentTraceQuantifier +toSequentTraceQuantifier AllTraces = ExistsNoTrace +toSequentTraceQuantifier ExistsTrace = ExistsSomeTrace + +-- | True iff the lemma can be used as a typing lemma. +isTypingLemma :: Lemma p -> Bool +isTypingLemma lem = + (AllTraces == L.get lTraceQuantifier lem) + && (TypingLemma `elem` L.get lAttributes lem) + + -- Lemma construction/modification ---------------------------------- -- | Create a new unproven lemma from a formula modulo E. -unprovenLemma :: String -> [LemmaAttribute] -> FormulaE -> Lemma ProofSkeleton -unprovenLemma name atts fmE = Lemma name fmE Nothing atts (unproven ()) +unprovenLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> FormulaE + -> Lemma ProofSkeleton +unprovenLemma name atts qua fmE = Lemma name qua fmE Nothing atts (unproven ()) -skeletonLemma :: String -> [LemmaAttribute] -> FormulaE +skeletonLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> FormulaE -> ProofSkeleton -> Lemma ProofSkeleton -skeletonLemma name atts fmE = Lemma name fmE Nothing atts +skeletonLemma name atts qua fmE = Lemma name qua fmE Nothing atts -- | The case-distinction kind allowed for a lemma lemmaCaseDistKind :: Lemma p -> CaseDistKind lemmaCaseDistKind lem | TypingLemma `elem` L.get lAttributes lem = UntypedCaseDist - | otherwise = TypedCaseDist + | otherwise = TypedCaseDist ------------------------------------------------------------------------------ @@ -297,7 +323,7 @@ RuleItem r | LemmaItem (Lemma p) | TextItem FormalComment - deriving( Show, Functor ) + deriving( Show, Eq, Ord, Functor ) -- | A theory contains a single set of rewriting rules modeling a protocol @@ -391,13 +417,6 @@ defaultOpenTheory :: OpenTheory defaultOpenTheory = Theory "default" emptySignaturePure [] [] --- | The default intruder theory; uses Maude to perform AC --- unification for computing the variants. -dhIntruderTheory :: MaudeHandle -> OpenTheory -dhIntruderTheory hnd = - Theory "intruder_variants" (emptySignaturePure { _sigMaudeInfo = dhMaudeSig }) - (dhIntruderRules `runReader` hnd) [] - -- | Open a theory by dropping the closed world assumption and values whose -- soundness dependens on it. openTheory :: ClosedTheory -> OpenTheory @@ -443,14 +462,21 @@ getProtoRuleEs = map openProtoRule . theoryRules -- | Get the proof context for a lemma of the closed theory. -getProofContext :: CaseDistKind -> ClosedTheory -> ProofContext -getProofContext kind thy = ProofContext +getProofContext :: Lemma a -> ClosedTheory -> ProofContext +getProofContext l thy = ProofContext ( L.get thySignature thy) ( L.get (crcRules . thyCache) thy) + kind ( L.get (cases . thyCache) thy) + inductionHint + (toSequentTraceQuantifier $ L.get lTraceQuantifier l) where - cases = case kind of UntypedCaseDist -> crcUntypedCaseDists - TypedCaseDist -> crcTypedCaseDists + kind = lemmaCaseDistKind l + cases = case kind of UntypedCaseDist -> crcUntypedCaseDists + TypedCaseDist -> crcTypedCaseDists + inductionHint + | any (`elem` [TypingLemma, InvariantLemma]) (L.get lAttributes l) = UseInduction + | otherwise = AvoidInduction -- | The classified set of rules modulo AC in this theory. getClassifiedRules :: ClosedTheory -> ClassifiedRules @@ -465,6 +491,10 @@ -- construction --------------- +-- -- | Convert a lemma to the corresponding guarded formula. +-- lemmaToGuarded :: Lemma p -> Maybe LNGuarded +-- lemmaToGuarded lem = + -- | Close a theory by closing its associated rule set and converting the proof -- skeletons to unannotated incremental proofs and caching AC variants as well -- as precomputed case distinctions. @@ -477,47 +507,100 @@ -> IO ClosedTheory closeTheory maudePath thy0 = do sig <- toSignatureWithMaude maudePath $ L.get thySignature thy0 - let cache = closeRuleCache typAsms sig rules $ L.get thyCache thy0 - addSorrys = checkAndExtendProver (sorryProver "not yet proven") + return $ closeTheoryWithMaude sig thy0 - -- Maude / Signature handle - hnd = L.get sigmMaudeHandle sig +-- | Close a theory given a maude signature. This signature must be valid for +-- the given theory. +closeTheoryWithMaude :: SignatureWithMaude -> OpenTheory -> ClosedTheory +closeTheoryWithMaude sig thy0 = do + proveTheory addSorrys $ Theory (L.get thyName thy0) sig cache items + where + cache = closeRuleCache typAsms sig rules $ L.get thyCache thy0 + addSorrys = checkAndExtendProver (sorryProver "not yet proven") - -- close all theory items: in parallel - items = (closeTheoryItem <$> L.get thyItems thy0) `using` parList rdeepseq - closeTheoryItem = foldTheoryItem - (RuleItem . closeProtoRule hnd) - (LemmaItem . ensureFormulaAC . fmap skeletonToIncrementalProof) - TextItem + -- Maude / Signature handle + hnd = L.get sigmMaudeHandle sig - -- extract typing lemmas - typAsms = do - LemmaItem lem <- items - guard (TypingLemma `elem` L.get lAttributes lem) - let toGuarded = fmap negateGuarded . fromFormulaNegate - case toGuarded <$> L.get lFormulaAC lem of - Just (Right gf) -> return gf - Just (Left err) -> error $ "closeTheory: " ++ err - _ -> mzero + -- close all theory items: in parallel + (items, _solveRel, _breakers) = (`runReader` hnd) $ addSolvingLoopBreakers + ((closeTheoryItem <$> L.get thyItems thy0) `using` parList rdeepseq) + closeTheoryItem = foldTheoryItem + (RuleItem . closeProtoRule hnd) + (LemmaItem . ensureFormulaAC . fmap skeletonToIncrementalProof) + TextItem - -- extract protocol rules - rules = theoryRules (Theory errClose errClose errClose items) - errClose = error "closeTheory" + -- extract typing lemmas + typAsms = do + LemmaItem lem <- items + guard (isTypingLemma lem) + let toGuarded = fmap negateGuarded . fromFormulaNegate + case toGuarded <$> L.get lFormulaAC lem of + Just (Right gf) -> return gf + Just (Left err) -> error $ "closeTheory: " ++ err + _ -> mzero - return $ proveTheory addSorrys $ Theory (L.get thyName thy0) sig cache items + -- extract protocol rules + rules = theoryRules (Theory errClose errClose errClose items) + errClose = error "closeTheory" + addSolvingLoopBreakers = useAutoLoopBreakersAC + (liftToItem $ enumPrems . L.get cprRuleAC) + (liftToItem $ enumConcs . L.get cprRuleAC) + (liftToItem $ getDisj . L.get (pracVariants . rInfo . cprRuleAC)) + addBreakers + where + liftToItem f (RuleItem ru) = f ru + liftToItem _ _ = [] + addBreakers bs (RuleItem ru) = + RuleItem (L.set (pracLoopBreakers . rInfo . cprRuleAC) bs ru) + addBreakers _ item = item + + + +-- Partial evaluation / abstract interpretation +----------------------------------------------- + +-- | Apply partial evaluation. +applyPartialEvaluation :: EvaluationStyle -> ClosedTheory -> ClosedTheory +applyPartialEvaluation evalStyle thy0 = + closeTheoryWithMaude sig $ + L.modify thyItems replaceProtoRules (openTheory thy0) + where + sig = L.get thySignature thy0 + ruEs = getProtoRuleEs thy0 + (st', ruEs') = (`runReader` L.get sigmMaudeHandle sig) $ + partialEvaluation evalStyle ruEs + + replaceProtoRules [] = [] + replaceProtoRules (item:items) + | isRuleItem item = + [ TextItem ("text", render ppAbsState) + + ] ++ map RuleItem ruEs' ++ filter (not . isRuleItem) items + | otherwise = item : replaceProtoRules items + + isRuleItem (RuleItem _) = True + isRuleItem _ = False + + ppAbsState = + (text $ " the abstract state after partial evaluation" + ++ " contains " ++ show (S.size st') ++ " facts:") $--$ + (numbered' $ map prettyLNFact $ S.toList st') $--$ + (text $ "This abstract state results in " ++ show (length ruEs') ++ + " refined multiset rewriting rules.\n" ++ + "Note that the original number of multiset rewriting rules was " + ++ show (length ruEs) ++ ".\n\n") + -- Applying provers ------------------- -- | A list of proof methods that could be applied to the given sequent. -applicableProofMethods :: ClosedTheory -> Sequent -> [ProofMethod] -applicableProofMethods thy se = do - m <- possibleProofMethods (L.get pcSignature ctxt) se +applicableProofMethods :: ProofContext -> Sequent -> [ProofMethod] +applicableProofMethods ctxt se = do + m <- possibleProofMethods ctxt se guard (isJust $ execProofMethod ctxt m se) return m - where - ctxt = getProofContext (L.get sCaseDistKind se) thy -- | Prove both the assertion soundness as well as all lemmas of the theory. If -- the prover fails on a lemma, then its proof remains unchanged. @@ -535,15 +618,15 @@ modify lProof add l where l = ensureFormulaAC l0 - kind = lemmaCaseDistKind l - se = formulaToSequent kind preItems $ fromJust $ L.get lFormulaAC l - ctxt = getProofContext kind thy + ctxt = getProofContext l thy + se = formulaToSequent ctxt preItems $ fromJust $ L.get lFormulaAC l add prf = fromMaybe prf $ runProver prover ctxt se prf -- | Convert a formula modulo AC to a sequent. -formulaToSequent :: CaseDistKind -> [TheoryItem r p] -> FormulaAC -> Sequent -formulaToSequent kind lems = - addLemmasToSequent lems . sequentFromFormula kind +formulaToSequent :: ProofContext -> [TheoryItem r p] -> FormulaAC -> Sequent +formulaToSequent ctxt lems = + addLemmasToSequent lems + . sequentFromFormula (L.get pcCaseDistKind ctxt) (L.get pcTraceQuantifier ctxt) -- | Add the lemmas that have an associated AC variant to this sequent. addLemmasToSequent :: [TheoryItem r p] -> Sequent -> Sequent @@ -567,7 +650,7 @@ set lFormulaAC (Just fmAC) l where -- FIXME: AC-variant of formula is formula itself. - -- This is ensured by well-formed check (not implemented yet). + -- This must be ensured by well-formed check (not implemented yet). fmAC = fromMaybe (L.get lFormulaE l) $ L.get lFormulaAC l @@ -593,9 +676,8 @@ change preItems (LemmaItem l0) = do let l1 = ensureFormulaAC l0 - kind = lemmaCaseDistKind l1 - ctxt = getProofContext kind thy - se <- formulaToSequent kind preItems <$> L.get lFormulaAC l1 + ctxt = getProofContext l1 thy + se <- formulaToSequent ctxt preItems <$> L.get lFormulaAC l1 l2 <- modA lProof (runProver prover ctxt se) l1 return $ LemmaItem l2 change _ _ = error "LemmaProof: change: impossible" @@ -639,14 +721,19 @@ as -> text (L.get lName l) <-> (brackets $ fsep $ punctuate comma $ map prettyLemmaAttribute as) where - prettyLemmaAttribute TypingLemma = text "typing" - prettyLemmaAttribute ReuseLemma = text "reuse" + prettyLemmaAttribute TypingLemma = text "typing" + prettyLemmaAttribute ReuseLemma = text "reuse" + prettyLemmaAttribute InvariantLemma = text "invariant" -- | Pretty print a lemma. prettyLemma :: HighlightDocument d => (p -> d) -> Lemma p -> d prettyLemma ppPrf l = kwLemmaModulo "E" <-> prettyLemmaName l <> colon $-$ - (nest 2 $ doubleQuotes $ prettyFormulaE $ L.get lFormulaE l) + (nest 2 $ + sep [ prettyTraceQuantifier $ L.get lTraceQuantifier l + , doubleQuotes $ prettyFormulaE $ L.get lFormulaE l + ] + ) $-$ maybe emptyDoc ppFormulaAC (L.get lFormulaAC l) $-$ @@ -666,9 +753,13 @@ ppFormulaACGuarded fmAC = case fromFormulaNegate fmAC of Left err -> multiComment_ ["conversion to doubly-guarded formula failed:", err] - Right gf -> multiComment - ( text "guarded formula characterizing all attacks:" $-$ + Right gf -> case toSequentTraceQuantifier $ L.get lTraceQuantifier l of + ExistsNoTrace -> multiComment + ( text "guarded formula characterizing all counter-examples:" $-$ doubleQuotes (prettyGuarded gf) ) + ExistsSomeTrace -> multiComment + ( text "guarded formula characterizing all satisfying traces:" $-$ + doubleQuotes (prettyGuarded (negateGuarded gf)) ) {- ppFormulaACInduction fmAC = case fmInd of @@ -680,15 +771,12 @@ where fmInd = applyInduction =<< fromFormulaNegate fmAC -} -{- + -- | Pretty-print a non-empty bunch of intruder rules. prettyIntruderVariants :: HighlightDocument d => [IntrRuleAC] -> d -prettyIntruderVariants [] = multiComment $ vsep - [ text "No intruder variants found. You can generate and cache them using the command" - , nest 2 (text "tamarin-prover intruder -O") - ] prettyIntruderVariants vs = vcat . intersperse (text "") $ map prettyIntrRuleAC vs +{- -- | Pretty-print the intruder variants section. prettyIntrVariantsSection :: HighlightDocument d => [IntrRuleAC] -> d prettyIntrVariantsSection rules = @@ -710,12 +798,14 @@ -- | Pretty print an closed rule together with its assertion soundness proof. prettyClosedProtoRule :: HighlightDocument d => ClosedProtoRule -> d prettyClosedProtoRule cru = - (prettyProtoRuleE $ L.get cprRuleE cru) $-$ - (nest 2 $ ppRuleAC $ L.get cprRuleAC cru) + (prettyProtoRuleE ruE) $--$ + (nest 2 $ prettyLoopBreakers (L.get rInfo ruAC) $-$ ppRuleAC) where - ppRuleAC ru - | isTrivialProtoRuleAC ru = multiComment_ ["has exactly the trivial AC variant"] - | otherwise = multiComment $ prettyProtoRuleAC ru + ruAC = L.get cprRuleAC cru + ruE = L.get cprRuleE cru + ppRuleAC + | isTrivialProtoVariantAC ruAC ruE = multiComment_ ["has exactly the trivial AC variant"] + | otherwise = multiComment $ prettyProtoRuleAC ruAC -- | Pretty print an open theory. prettyOpenTheory :: HighlightDocument d => OpenTheory -> d @@ -726,12 +816,18 @@ -- | Pretty print a closed theory. prettyClosedTheory :: HighlightDocument d => ClosedTheory -> d -prettyClosedTheory = +prettyClosedTheory thy = prettyTheory prettySignatureWithMaude (const emptyDoc) -- (prettyIntrVariantsSection . intruderRules . L.get crcRules) prettyClosedProtoRule prettyIncrementalProof + thy + -- $--$ + -- (multiComment $ + -- let ruEs = getProtoRuleEs thy + -- in prettyAbstractState ruEs $ absInterpretation ruEs + -- ) prettyClosedSummary :: Document d => ClosedTheory -> d prettyClosedSummary thy = @@ -740,17 +836,27 @@ lemmaSummaries = do LemmaItem lem <- L.get thyItems thy let (status, Sum siz) = foldProof proofStepSummary $ L.get lProof lem - return $ text (L.get lName lem) <> colon <-> - text (showProofStatus status) <-> + quantifier = (toSequentTraceQuantifier $ L.get lTraceQuantifier lem) + analysisType = parens $ prettyTraceQuantifier $ L.get lTraceQuantifier lem + return $ text (L.get lName lem) <-> analysisType <> colon <-> + text (showProofStatus quantifier status) <-> parens (integer siz <-> text "steps") proofStepSummary = proofStepStatus &&& const (Sum (1::Integer)) + +-- | Pretty print a 'TraceQuantifier'. +prettyTraceQuantifier :: Document d => TraceQuantifier -> d +prettyTraceQuantifier ExistsTrace = text "exists-trace" +prettyTraceQuantifier AllTraces = text "all-traces" + + -- Instances: FIXME: Sort them into the right files -------------------------------------------------- $( derive makeBinary ''TheoryItem) $( derive makeBinary ''LemmaAttribute) +$( derive makeBinary ''TraceQuantifier) $( derive makeBinary ''Lemma) $( derive makeBinary ''ClosedProtoRule) $( derive makeBinary ''ClosedRuleCache) @@ -758,6 +864,7 @@ $( derive makeNFData ''TheoryItem) $( derive makeNFData ''LemmaAttribute) +$( derive makeNFData ''TraceQuantifier) $( derive makeNFData ''Lemma) $( derive makeNFData ''ClosedProtoRule) $( derive makeNFData ''ClosedRuleCache) diff --git a/src/Theory/AbstractInterpretation.hs b/src/Theory/AbstractInterpretation.hs new file mode 100644 --- /dev/null +++ b/src/Theory/AbstractInterpretation.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE BangPatterns, ViewPatterns #-} +-- | +-- Copyright : (c) 2012 Benedikt Schmidt & Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- +-- Abstract intepretation for partial evaluation of multiset rewriting +-- systems. +module Theory.AbstractInterpretation ( + -- * Combinator to define abstract interpretations + interpretAbstractly + + -- ** Actual interpretations + , EvaluationStyle(..) + , partialEvaluation + + ) where + +import Debug.Trace + +import Control.Basics +import Control.Monad.Bind +import Control.Monad.Reader + +import Data.List +import qualified Data.Set as S +import Data.Traversable (traverse) +import Data.Label + +import Text.PrettyPrint.Highlight +import Term.Substitution +import Theory.Rule + +------------------------------------------------------------------------------ +-- Abstract enough versions of builtin rules for computing +------------------------------------------------------------------------------ + + +-- | Higher-order combinator to construct abstract interpreters. +interpretAbstractly + :: (Eq s, HasFrees i, Apply i) + => ([Equal LNFact] -> [LNSubstVFresh]) + -- ^ Unification of equalities over facts. We assume that facts with + -- different tags are never unified. + -> s -- ^ Initial abstract state. + -> (LNFact -> s -> s) -- ^ Add a fact to the abstract state + -> (s -> [LNFact]) -- ^ Facts of a state. + -> [Rule i] + -- ^ Multiset rewriting rules to apply abstractly. + -> [(s, [Rule i])] + -- ^ Sequence of abstract states and refined versions of all given + -- multiset rewriting rules. +interpretAbstractly unifyFactEqs initState addFact stateFacts rus = + go st0 + where + st0 = addFact (freshFact (varTerm (LVar "z" LSortFresh 0))) $ + addFact (inFact (varTerm (LVar "z" LSortMsg 0))) $ + initState + + -- Repeatedly refine all rules and add all their conclusions until the + -- state doesn't change anymore. + go st = + (st, rus') : if st == st' then [] else go st' + where + rus' = concatMap refineRule rus + st' = foldl' (flip addFact) st $ concatMap (get rConcs) rus' + + -- Refine a rule in the context of an abstract state: for all premise + -- to state facts combinations, try to solve the corresponding + -- E-unification problem. If successful, return the rule with the + -- unifier applied. + refineRule ru = (`evalFreshT` avoid ru) $ do + eqs <- forM (get rPrems ru) $ \prem -> msum $ do + fa <- stateFacts st + guard (factTag prem == factTag fa) + -- we compute a list of 'FreshT []' actions for the outer msum + return (Equal prem <$> rename fa) + subst <- msum $ freshToFree <$> unifyFactEqs eqs + return $ apply subst ru + +-- | How to report on performing a partial evaluation. +data EvaluationStyle = Silent | Summary | Tracing + +-- | Concrete partial evaluator activated with flag: --partial-evaluation +partialEvaluation :: EvaluationStyle + -> [ProtoRuleE] -> WithMaude (S.Set LNFact, [ProtoRuleE]) +partialEvaluation evalStyle ruEs = reader $ \hnd -> + consumeEvaluation $ interpretAbstractly + ((`runReader` hnd) . unifyLNFactEqs) -- FIXME: Use E-unification here + S.empty + (S.insert . absFact) + S.toList + ruEs + where + consumeEvaluation [] = error "partialEvaluation: impossible" + consumeEvaluation ((st0, rus0) : rest0) = + go (0 :: Int) st0 rus0 rest0 + where + go _ st rus [] = + ( st + , nubBy eqModuloFreshnessNoAC $ -- remove duplicates + map ((`evalFresh` nothingUsed) . rename) rus + ) + go i st _ ((st', rus') : rest) = + withTrace (go (i + 1) st' rus' rest) + where + incDesc = " partial evaluation: step " ++ show i ++ " added " ++ + show (S.size st' - S.size st) ++ " facts" + withTrace = case evalStyle of + Silent -> id + Summary -> trace incDesc + Tracing -> trace $ incDesc ++ "\n\n" ++ + ( render $ nest 2 $ numbered' $ map prettyLNFact $ + S.toList $ st' `S.difference` st ) ++ "\n" + + + -- NOTE: We should use an abstract state that identifies all variables at + -- the same position provided they have the same sort. + absFact :: LNFact -> LNFact + absFact fa = case fa of + Fact OutFact _ -> outFact (varTerm (LVar "z" LSortMsg 0)) + Fact tag ts -> Fact tag $ evalAbstraction $ traverse absTerm ts + where + evalAbstraction = (`evalBind` noBindings) . (`evalFreshT` nothingUsed) + + absTerm t = case viewTerm t of + Lit (Con _) -> pure t + FApp (sym@(NonAC (_f,_k))) ts + -> fApp sym <$> traverse absTerm ts + -- | "p" `isPrefixOf` f -> FApp sym <$> traverse absTerm ts + _ -> importBinding mkVar t (varName t) + where + mkVar name idx = varTerm (LVar name (sortOfLNTerm t) idx) + varName (viewTerm -> Lit (Var v)) = lvarName v + varName _ = "z" diff --git a/src/Theory/Atom.hs b/src/Theory/Atom.hs --- a/src/Theory/Atom.hs +++ b/src/Theory/Atom.hs @@ -5,8 +5,11 @@ , DeriveDataTypeable , TupleSections , TemplateHaskell + , ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + -- spurious warnings for view patterns -- | -- Copyright : (c) 2011, 2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE) @@ -31,8 +34,8 @@ ) where -import Term.Rewriting.NormAC -import Theory.Fact +-- import Term.Rewriting.NormAC +import Theory.Rule import Theory.Pretty import Data.Monoid (mappend) @@ -56,7 +59,7 @@ | Less t t | Last t | DedBefore t t - | EdgeA (t, Int) (t, Int) + | EdgeA (t, ConcIdx) (t, PremIdx) deriving( Eq, Ord, Show, Data, Typeable ) -- | @LAtom@ are the atoms we actually use in graph formulas input by the user. @@ -122,18 +125,18 @@ apply _ x@(Bound _) = x apply subst x@(Free v) = maybe x extractVar $ imageOf subst v where - extractVar (Lit (Var v')) = Free v' - extractVar t = + extractVar (viewTerm -> Lit (Var v')) = Free v' + extractVar _t = error $ "apply (BLVar): variable '" ++ show v ++ - "' substituted with term '" ++ show t ++ "'" + "' substituted with term '" -- ++ show _t ++ "'" instance Apply BLTerm where - apply subst = normAC . (>>= applyBLLit) + apply subst = (`bindTerm` applyBLLit) where applyBLLit :: Lit Name BLVar -> BLTerm applyBLLit l@(Var (Free v)) = - maybe (Lit l) (fmap (fmap Free)) (imageOf subst v) - applyBLLit l = Lit l + maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v) + applyBLLit l = lit l instance Apply BLAtom where apply subst (Action i fact) = Action (apply subst i) (apply subst fact) diff --git a/src/Theory/Fact.hs b/src/Theory/Fact.hs --- a/src/Theory/Fact.hs +++ b/src/Theory/Fact.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell, FlexibleContexts, DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Copyright : (c) 2011, 2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE) @@ -33,6 +34,7 @@ , DirTag(..) , kFactView + , dedFactView , isKFact , kuFact , kdFact @@ -42,6 +44,7 @@ , outFact , inFact , kLogFact + , dedLogFact , protoFact -- * NFact @@ -51,6 +54,7 @@ , LFact , LNFact , unifyLNFactEqs + , unifiableLNFacts , matchLNFact -- * Pretty-Printing @@ -77,7 +81,7 @@ import Term.Unification -import Text.Isar +import Text.PrettyPrint.Class ------------------------------------------------------------------------------ @@ -91,10 +95,12 @@ data FactTag = ProtoFact Multiplicity String Int -- ^ A protocol fact together with its arity and multiplicity. | FreshFact -- ^ Freshly generated value. - | OutFact -- ^ Sent by the protocol - | InFact -- ^ Officially known by the intruder/network. + | OutFact -- ^ Sent by the protocol + | InFact -- ^ Officially known by the intruder/network. | KUFact -- ^ Up-knowledge fact in messsage deduction. | KDFact -- ^ Down-knowledge fact in message deduction. + | DedFact -- ^ Log-fact denoting that the intruder deduced + -- a message using a construction rule. deriving( Eq, Ord, Show, Typeable, Data ) -- | Facts. @@ -133,18 +139,18 @@ ------------------ -- | Message fact exponentation tag. -data ExpTag = IsExp | IsNoExp +data ExpTag = CannotExp | CanExp deriving( Eq, Ord, Show) -- | Exponentiation-symbol to term. expTagToTerm :: ExpTag -> LNTerm -expTagToTerm IsExp = Lit (Con (Name PubName (NameId ("exp")))) -expTagToTerm IsNoExp = Lit (Con (Name PubName (NameId ("noexp")))) +expTagToTerm CannotExp = lit (Con (Name PubName (NameId ("noexp")))) +expTagToTerm CanExp = lit (Con (Name PubName (NameId ("exp")))) -- | Term to exponentiation-symbol. termToExpTag :: LNTerm -> Maybe ExpTag -termToExpTag (Lit (Con (Name PubName (NameId ("exp"))))) = return IsExp -termToExpTag (Lit (Con (Name PubName (NameId ("noexp"))))) = return IsNoExp +termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("noexp"))))) = return CannotExp +termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("exp"))))) = return CanExp termToExpTag _ = mzero @@ -169,17 +175,27 @@ kFactView :: LNFact -> Maybe (DirTag, Maybe ExpTag, LNTerm) kFactView fa = case fa of Fact KUFact [e, m] -> Just (UpK, termToExpTag e, m) - Fact KUFact _ -> errMalformed + Fact KUFact _ -> errMalformed "kFactView" fa Fact KDFact [e, m] -> Just (DnK, termToExpTag e, m) - Fact KDFact _ -> errMalformed + Fact KDFact _ -> errMalformed "kFactView" fa _ -> Nothing - where - errMalformed = error $ show "viewKFact: malformed fact: " ++ show fa +-- | View a deduction logging fact. +dedFactView :: LNFact -> Maybe LNTerm +dedFactView fa = case fa of + Fact DedFact [m] -> Just m + Fact DedFact _ -> errMalformed "dedFactView" fa + _ -> Nothing + -- | True if the fact is a message-deduction fact. isKFact :: LNFact -> Bool isKFact = isJust . kFactView +-- | Mark a fact as malformed. +errMalformed :: String -> LNFact -> a +errMalformed caller fa = + error $ caller ++ show ": malformed fact: " ++ show fa + -- Constructing facts --------------------- @@ -199,6 +215,11 @@ kLogFact :: t -> Fact t kLogFact = protoFact Linear "K" . return +-- | A fact logging that the intruder deduced a message using a construction +-- rule. We use this to formulate invariants over normal dependency graphs. +dedLogFact :: t -> Fact t +dedLogFact = Fact DedFact . return + -- | A protocol fact denotes a fact generated by a protocol rule. protoFact :: Multiplicity -> String -> [t] -> Fact t protoFact multi name ts = Fact (ProtoFact multi name (length ts)) ts @@ -234,9 +255,10 @@ ProtoFact _ _ k -> k KUFact -> 2 KDFact -> 2 + DedFact -> 1 FreshFact -> 1 - InFact -> 1 - OutFact -> 1 + InFact -> 1 + OutFact -> 1 -- | The arity of a 'Fact'. factArity :: Fact t -> Int @@ -274,10 +296,13 @@ -- | Unify a list of @LFact@ equalities. unifyLNFactEqs :: [Equal LNFact] -> WithMaude [LNSubstVFresh] unifyLNFactEqs eqs - -- TODO: Check if the arity of the facts is also checked. | all (evalEqual . fmap factTag) eqs = - unifyLNTerm (map (fmap (listToTerm . factTerms)) eqs) + unifyLNTerm (map (fmap (fAppList . factTerms)) eqs) | otherwise = return [] + +-- | 'True' iff the two facts are unifiable. +unifiableLNFacts :: LNFact -> LNFact -> WithMaude Bool +unifiableLNFacts fa1 fa2 = (not . null) <$> unifyLNFactEqs [Equal fa1 fa2] -- | @matchLFact t p@ is a complete set of AC matchers for the term fact @t@ -- and the pattern fact @p@. @@ -299,6 +324,7 @@ showFactTag tag = case tag of KUFact -> "!KU" KDFact -> "!KD" + DedFact -> "Ded" InFact -> "In" OutFact -> "Out" FreshFact -> "Fr" diff --git a/src/Theory/Formula.hs b/src/Theory/Formula.hs --- a/src/Theory/Formula.hs +++ b/src/Theory/Formula.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, BangPatterns, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, BangPatterns #-} {-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + -- spurious warnings for view patterns -- | -- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt -- License : GPL v3 (see LICENSE) @@ -109,7 +112,7 @@ -- | Fold a formula. {-# INLINE foldFormulaScope #-} -foldFormulaScope :: (Int -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b) +foldFormulaScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b) -> (b -> b) -> (Connective -> b -> b -> b) -> (Quantifier -> s -> b -> b) -> Formula s c v @@ -127,19 +130,26 @@ -- Instances ------------ - +{- instance Functor (Formula s c) where fmap f = foldFormula (Ato . fmap (fmap (fmap (fmap f)))) TF Not Conn Qua +-} instance Foldable (Formula s c) where foldMap f = foldFormula (foldMap (foldMap (foldMap (foldMap f)))) mempty id (const mappend) (const $ const id) +traverseFormula :: (Ord v, Ord c, Ord v', Applicative f) + => (v -> f v') -> Formula s c v -> f (Formula s c v') +traverseFormula f = foldFormula (liftA Ato . traverse (traverseTerm (traverse (traverse f)))) + (pure . TF) (liftA Not) + (liftA2 . Conn) ((liftA .) . Qua) +{- instance Traversable (Formula a s) where - traverse f = foldFormula (liftA Ato . traverse (traverse (traverse (traverse f)))) + traverse f = foldFormula (liftA Ato . traverseAtom (traverseTerm (traverseLit (traverseBVar f)))) (pure . TF) (liftA Not) (liftA2 . Conn) ((liftA .) . Qua) - +-} -- Abbreviations ---------------- @@ -174,19 +184,19 @@ type LNFormula = Formula (String, LSort) Name LVar -- | Change the representation of atoms. -mapAtoms :: (Int -> Atom (VTerm c (BVar v)) +mapAtoms :: (Integer -> Atom (VTerm c (BVar v)) -> Atom (VTerm c1 (BVar v1))) -> Formula s c v -> Formula s c1 v1 mapAtoms f = foldFormulaScope (\i a -> Ato $ f i a) TF Not Conn Qua -- | @openFormula f@ returns @Just (v,Q,f')@ if @f = Q v. f'@ modulo -- alpha renaming and @Nothing otherwise@. @v@ is always chosen to be fresh. -openFormula :: (MonadFresh m) +openFormula :: (MonadFresh m, Ord c) => LFormula c -> Maybe (Quantifier, m (LVar, LFormula c)) openFormula (Qua qua (n,s) fm) = Just ( qua , do x <- freshLVar n s - return $ (x, mapAtoms (\i a -> fmap (fmap (subst x i)) a) fm) + return $ (x, mapAtoms (\i a -> fmap (mapLits (subst x i)) a) fm) ) where subst x i (Var (Bound i')) | i == i' = Var $ Free x @@ -194,11 +204,14 @@ openFormula _ = Nothing +mapLits :: (Ord a, Ord b) => (a -> b) -> Term a -> Term b +mapLits f (viewTerm -> Lit l) = lit . f $ l +mapLits f (viewTerm -> FApp o as) = fApp o (map (mapLits f) as) -- | @openFormulaPrefix f@ returns @Just (vs,Q,f')@ if @f = Q v_1 .. v_k. f'@ -- modulo alpha renaming and @Nothing otherwise@. @vs@ is always chosen to be -- fresh. -openFormulaPrefix :: (MonadFresh m) +openFormulaPrefix :: (MonadFresh m, Ord c) => LFormula c -> m ([LVar], Quantifier, LFormula c) openFormulaPrefix f0 = case openFormula f0 of Nothing -> error $ "openFormulaPrefix: no outermost quantifier" @@ -222,7 +235,7 @@ instance HasFrees LNFormula where foldFrees f = foldMap (foldFrees f) - mapFrees f = traverse (mapFrees f) + mapFrees f = traverseFormula (mapFrees f) instance Apply LNFormula where apply subst = mapAtoms (const $ apply subst) @@ -235,19 +248,19 @@ type FormulaAC = LFormula Name -- | Introduce a bound variable for a free variable. -quantify :: Eq v => v -> Formula s c v -> Formula s c v +quantify :: (Ord c, Ord v, Eq v) => v -> Formula s c v -> Formula s c v quantify x = - mapAtoms (\i a -> fmap (fmap (fmap (>>= (subst i)))) a) + mapAtoms (\i a -> fmap (mapLits (fmap (>>= subst i))) a) where subst i v | v == x = Bound i | otherwise = Free v -- | Create a universal quantification with a sort hint for the bound variable. -forall :: Eq v => s -> v -> Formula s c v -> Formula s c v +forall :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v forall hint x = Qua All hint . quantify x -- | Create a existential quantification with a sort hint for the bound variable. -exists :: Eq v => s -> v -> Formula s c v -> Formula s c v +exists :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v exists hint x = Qua Ex hint . quantify x ------------------------------------------------------------------------------ @@ -255,7 +268,7 @@ ------------------------------------------------------------------------------ -- | Pretty print a formula. -prettyLFormula :: (HighlightDocument d, MonadFresh m) +prettyLFormula :: (HighlightDocument d, MonadFresh m, Ord c) => (Atom (VTerm c LVar) -> d) -- ^ Function for pretty printing atoms -> LFormula c -- ^ Formula to pretty print. -> m d -- ^ Pretty printed formula. @@ -265,7 +278,7 @@ extractFree (Free v) = v extractFree (Bound i) = error $ "prettyFormula: illegal bound variable '" ++ show i ++ "'" - pp (Ato a) = return $ ppAtom (fmap (fmap (fmap extractFree)) a) + pp (Ato a) = return $ ppAtom (fmap (mapLits (fmap extractFree)) a) pp (TF True) = return $ operator_ "T" -- "⊤" pp (TF False) = return $ operator_ "F" -- "⊥" diff --git a/src/Theory/IntruderRules.hs b/src/Theory/IntruderRules.hs --- a/src/Theory/IntruderRules.hs +++ b/src/Theory/IntruderRules.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + -- spurious warnings for view patterns -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt -- License : GPL v3 (see LICENSE) @@ -13,20 +15,25 @@ -- , xorIntruderRules -- there are no multiset intruder rules ) where -import Theory.Rule +import Control.Monad.Fresh +import Control.Basics +import Control.Monad.Reader + +import qualified Data.Set as S +import Data.List +import qualified Data.ByteString.Char8 as BC + +import Extension.Data.Label + +import Utils.Misc + import Term.SubtermRule import Term.Positions +import Term.Maude.Signature import Term.Rewriting.Norm import Term.Narrowing.Variants.Compute -import Utils.Misc - -import Control.Monad.Fresh -import Data.List -import Control.Basics -import Extension.Data.Label - -import Control.Monad.Reader +import Theory.Rule @@ -59,19 +66,23 @@ [ Rule CoerceRule [Fact KDFact [f_var, x_var]] [Fact KUFact [f_var,x_var]] - [] - , Rule (IntrApp "pub") + [dedLogFact x_var] + , Rule PubConstrRule [] [Fact KUFact [f_var,x_pub_var]] - [] - , Rule (IntrApp "fresh") + [dedLogFact x_pub_var] + , Rule FreshConstrRule [Fact FreshFact [x_fresh_var]] [Fact KUFact [f_var,x_fresh_var]] - [] - , Rule (IntrApp "isend") + [dedLogFact x_fresh_var] + , Rule ISendRule [Fact KUFact [f_var, x_var]] [Fact InFact [x_var]] - [protoFact Linear "K" [x_var]] + [kLogFact x_var] + , Rule IRecvRule + [Fact OutFact [x_var]] + [Fact KDFact [expTagToTerm CanExp, x_var]] + [] ] where f_var = varTerm (LVar "f_" LSortMsg 0) @@ -84,14 +95,14 @@ ------------------------------------------------------------------------------ destructionRules :: StRule -> [IntrRuleAC] -destructionRules (StRule lhs@(FApp (NonAC (f,_)) _) (RhsPosition pos)) = +destructionRules (StRule lhs@(viewTerm -> FApp (NonAC (f,_)) _) (RhsPosition pos)) = go [] lhs pos where - rhs = lhs >* pos - go _ _ [] = [] + rhs = lhs `atPos` pos + go _ _ [] = [] -- term already in premises - go _ (FApp _ _) (_:[]) = [] - go uprems (FApp _ as) (i:p) = + go _ (viewTerm -> FApp _ _) (_:[]) = [] + go uprems (viewTerm -> FApp _ as) (i:p) = irule ++ go uprems' t' p where uprems' = uprems++[ t | (j, t) <- zip [0..] as, i /= j ] @@ -101,9 +112,9 @@ dfact <- kdFact Nothing t' ufacts <- mapM (kuFact Nothing) uprems' concfact <- kdFact Nothing rhs - return [ Rule (IntrApp f) (dfact:ufacts) [concfact] [] ] + return [ Rule (DestrRule (BC.unpack f)) (dfact:ufacts) [concfact] [] ] else [] - go _ (Lit _) (_:_) = + go _ (viewTerm -> Lit _) (_:_) = error "IntruderRules.destructionRules: impossible, position invalid" destructionRules _ = [] @@ -127,18 +138,19 @@ -- the free (not Xor, DH, and MSet) part of the given signature. subtermIntruderRules :: MaudeSig -> [IntrRuleAC] subtermIntruderRules maudeSig = - minimizeIntruderRules $ concatMap destructionRules (stRules maudeSig) - ++ constructionRules (funSig maudeSig) + minimizeIntruderRules $ concatMap destructionRules (S.toList $ stRules maudeSig) + ++ constructionRules (functionSymbols maudeSig) constructionRules :: FunSig -> [IntrRuleAC] constructionRules fSig = - [ createRule s k | (s,k) <- fSig ] + [ createRule s k | (s,k) <- S.toList fSig ] where createRule s k = (`evalFresh` nothingUsed) $ do vars <- map varTerm <$> (sequence $ replicate k (freshLVar "x" LSortMsg)) pfacts <- mapM (kuFact Nothing) vars - concfact <- kuFact (Just IsNoExp) (FApp (NonAC (s,k)) vars) - return $ Rule (IntrApp s) pfacts [concfact] [] + let m = fApp (NonAC (s,k)) vars + concfact <- kuFact (Just CanExp) m + return $ Rule (ConstrRule (BC.unpack s)) pfacts [concfact] [dedLogFact m] dropExpTag :: Fact a -> Fact a dropExpTag (Fact KUFact [_e,m]) = Fact KUFact [m] @@ -151,45 +163,51 @@ dhIntruderRules :: WithMaude [IntrRuleAC] dhIntruderRules = reader $ \hnd -> minimizeIntruderRules $ - [expRule True, invRule True] - ++ concatMap (variants hnd) [expRule False, invRule False] + [ expRule ConstrRule kuFact (return . dedLogFact) + , invRule ConstrRule kuFact (return . dedLogFact) + ] ++ + concatMap (variantsIntruder hnd) + [ expRule DestrRule kdFact (const []) + , invRule DestrRule kdFact (const []) + ] where - expRule isConstr = (`evalFresh` nothingUsed) $ do + expRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do b <- varTerm <$> freshLVar "x" LSortMsg e <- varTerm <$> freshLVar "x" LSortMsg - bfact <- fact isConstr (Just IsNoExp) b + bfact <- kudFact (Just CanExp) b efact <- kuFact Nothing e - concfact <- fact isConstr (Just IsExp) (FApp (NonAC ("exp",2)) [b, e]) - return $ Rule (IntrApp "exp") [bfact, efact] [concfact] [] + let conc = fAppExp (b, e) + concfact <- kudFact (Just CannotExp) conc + return $ Rule (mkInfo "exp") [bfact, efact] [concfact] (mkAction conc) - invRule isConstr = (`evalFresh` nothingUsed) $ do + invRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do x <- varTerm <$> freshLVar "x" LSortMsg - bfact <- fact isConstr Nothing x - concfact <- fact isConstr (Just IsNoExp) (FApp (NonAC invSym) [x]) - return $ Rule (IntrApp "inv") [bfact] [concfact] [] + bfact <- kudFact Nothing x + let conc = fAppInv x + concfact <- kudFact (Just CanExp) conc + return $ Rule (mkInfo "inv") [bfact] [concfact] (mkAction conc) - fact True = kuFact - fact False = kdFact - variants hnd ru = do - let concTerms = concatMap factTerms - (get rPrems ru++get rConcs ru++get rActs ru) - fsigma <- computeVariants (listToTerm concTerms) `runReader` hnd - let sigma = freshToFree fsigma `evalFreshAvoiding` concTerms - ruvariant = normRule' (apply sigma ru) `runReader` hnd - guard (frees (get rConcs ruvariant) /= [] && - -- ground terms are already deducible by applying construction rules - ruvariant /= ru && - -- this is a construction rule - (map dropExpTag (get rConcs ruvariant)) - \\ (map dropExpTag (get rPrems ruvariant)) /= [] - -- The conclusion is included in the premises - ) +variantsIntruder :: MaudeHandle -> IntrRuleAC -> [IntrRuleAC] +variantsIntruder hnd ru = do + let concTerms = concatMap factTerms + (get rPrems ru++get rConcs ru++get rActs ru) + fsigma <- computeVariants (fAppList concTerms) `runReader` hnd + let sigma = freshToFree fsigma `evalFreshAvoiding` concTerms + ruvariant = normRule' (apply sigma ru) `runReader` hnd + guard (frees (get rConcs ruvariant) /= [] && + -- ground terms are already deducible by applying construction rules + ruvariant /= ru && + -- this is a construction rule + (map dropExpTag (get rConcs ruvariant)) + \\ (map dropExpTag (get rPrems ruvariant)) /= [] + -- The conclusion is included in the premises + ) - case concatMap factTerms $ get rConcs ruvariant of - [_, FApp (AC Mult) _] -> - fail "Rules with product conclusion are redundant" - _ -> return ruvariant + case concatMap factTerms $ get rConcs ruvariant of + [_, viewTerm -> FApp (AC Mult) _] -> + fail "Rules with product conclusion are redundant" + _ -> return ruvariant normRule' :: IntrRuleAC -> WithMaude IntrRuleAC diff --git a/src/Theory/Parser.hs b/src/Theory/Parser.hs --- a/src/Theory/Parser.hs +++ b/src/Theory/Parser.hs @@ -12,6 +12,7 @@ , parseOpenTheoryString , parseProofMethod , parseLemma + , parseIntruderRulesDH ) where import Prelude hiding (id, (.)) @@ -22,14 +23,12 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.Monoid -import Data.Maybe +import qualified Data.ByteString.Char8 as BC import Control.Monad import Control.Applicative hiding (empty, many, optional) import Control.Category -import Extension.Prelude - import Text.Parsec.Pos import Text.Parsec hiding (token, (<|>), string ) import qualified Text.Parsec as P @@ -39,8 +38,9 @@ , alexGetPos, alexMonadScan ) import Term.SubtermRule +import Term.Substitution -import Text.Isar (render) +import Text.PrettyPrint.Class (render) import Theory @@ -113,12 +113,16 @@ -- | Parse an identifier as a string identifier :: Parser String identifier = token extract - where extract (IDENT name) = Just $ name - extract _ = Nothing + where extract (IDENT name) + -- don't allow certain reserved words as identifiers + | not (name `elem` ["in","let","rule"]) = Just name + extract _ = Nothing --- | Parse a fixed string which could be an identifier. +-- | Parse an identifier as a string string :: String -> Parser () -string cs = (try $ do { i <- identifier; guard (i == cs) }) ('`' : cs ++ "'") +string cs = token extract + where extract (IDENT name) | cs == name = Just () + extract _ = Nothing -- | Parse a sequence of fixed strings. strings :: [String] -> Parser () @@ -176,6 +180,10 @@ -> FilePath -> IO OpenTheory parseOpenTheory flags = parseFile (theory flags) +-- | Parse DH intruder rules. +parseIntruderRulesDH :: FilePath -> IO [IntrRuleAC] +parseIntruderRulesDH = parseFile (setState dhMaudeSig >> many intrRule) + -- | Parse a security protocol theory file. -- TODO: This function seems to parse a string, not a file from a file path? parseProofMethod :: FilePath -> Either ParseError ProofMethod @@ -245,10 +253,10 @@ ------------------------------------------------------------------------------ -- | Parse an identifier possibly indexed with a number. -indexedIdentifier :: Parser (String, Int) -indexedIdentifier = - -- FIXME: It might be confusing that 'x.0' and 'x' denote the same variable - (\s mi -> (s, fromMaybe 0 mi)) <$> identifier <*> optionMaybe (try (kw DOT *> integer)) +indexedIdentifier :: Parser (String, Integer) +indexedIdentifier = do + (,) <$> identifier + <*> option 0 (try (kw DOT *> (fromIntegral <$> integer))) -- | Parse a logical variable with the given sorts allowed. sortedLVar :: [LSort] -> Parser LVar @@ -299,79 +307,80 @@ lookupNonACArity :: String -> Parser Int lookupNonACArity op = do maudeSig <- getState - case lookup op (funSigForMaudeSig maudeSig) of + case lookup (BC.pack op) (S.toList $ allFunctionSymbols maudeSig) of Nothing -> fail $ "unknown operator `" ++ op ++ "'" Just k -> return k -- | Parse an n-ary operator application for arbitrary n. -naryOpApp :: Parser (Term l) -> Parser (Term l) -naryOpApp lit = do +naryOpApp :: Ord l => Parser (Term l) -> Parser (Term l) +naryOpApp plit = do op <- identifier k <- lookupNonACArity op ts <- parens $ if k == 1 - then return <$> tupleterm lit - else sepBy (multterm lit) (kw COMMA) + then return <$> tupleterm plit + else sepBy (multterm plit) (kw COMMA) let k' = length ts when (k /= k') $ fail $ "operator `" ++ op ++"' has arity " ++ show k ++ ", but here it is used with arity " ++ show k' - return $ FApp (NonAC (op, k')) ts + return $ fAppNonAC (BC.pack op, k') ts -- | Parse a binary operator written as @op{arg1}arg2@. -binaryAlgApp :: Parser (Term l) -> Parser (Term l) -binaryAlgApp lit = do +binaryAlgApp :: Ord l => Parser (Term l) -> Parser (Term l) +binaryAlgApp plit = do op <- identifier k <- lookupNonACArity op - arg1 <- kw LBRACE *> tupleterm lit <* kw RBRACE - arg2 <- term lit + arg1 <- kw LBRACE *> tupleterm plit <* kw RBRACE + arg2 <- term plit when (k /= 2) $ fail $ "only operators of arity 2 can be written using the `op{t1}t2' notation" - return $ FApp (NonAC (op, 2)) [arg1, arg2] + return $ fAppNonAC (BC.pack op, 2) [arg1, arg2] -- | Parse a term. -term :: Parser (Term l) -> Parser (Term l) -term lit = asum +term :: Ord l => Parser (Term l) -> Parser (Term l) +term plit = asum [ pairing "pairs" - , parens (multterm lit) - , kw UNDERSCORE *> (FApp (NonAC invSym) . return <$> term lit) - , string "1" *> pure (FApp (NonAC oneSym) []) + , parens (multterm plit) + , string "1" *> pure fAppOne , application "function application" , nullaryApp - , lit + , plit ] "term" where - application = asum $ map (try . ($ lit)) [naryOpApp, binaryAlgApp] - pairing = kw LESS *> tupleterm lit <* kw GREATER + application = asum $ map (try . ($ plit)) [naryOpApp, binaryAlgApp] + pairing = kw LESS *> tupleterm plit <* kw GREATER nullaryApp = do maudeSig <- getState - asum [ try (string sym) *> pure (FApp (NonAC (sym,0)) []) - | (sym,0) <- funSigForMaudeSig maudeSig ] + asum [ try (string (BC.unpack sym)) *> pure (fApp (NonAC (sym,0)) []) + | (sym,0) <- S.toList $ allFunctionSymbols maudeSig ] -- | A left-associative sequence of exponentations. -expterm :: Parser (Term l) -> Parser (Term l) -expterm lit = chainl1 (term lit) ((\a b -> FApp (NonAC expSym) [a,b]) <$ kw HAT) +expterm :: Ord l => Parser (Term l) -> Parser (Term l) +expterm plit = chainl1 (term plit) ((\a b -> fAppExp (a,b)) <$ kw HAT) -- | A left-associative sequence of multiplications. -multterm :: Parser (Term l) -> Parser (Term l) -multterm lit = chainl1 (expterm lit) ((\a b -> FApp (AC Mult) [a,b]) <$ kw STAR) - -- FIXME: parse as n-ary multiplication +multterm :: Ord l => Parser (Term l) -> Parser (Term l) +multterm plit = do + dh <- enableDH <$> getState + if dh -- if DH is not enabled, do not accept 'multterm's and 'expterm's + then chainl1 (expterm plit) ((\a b -> fAppMult [a,b]) <$ kw STAR) + else term plit -- | A right-associative sequence of tuples. -tupleterm :: Parser (Term l) -> Parser (Term l) -tupleterm lit = chainr1 pterm ((\a b -> FApp (NonAC pairSym) [a,b])<$ kw COMMA) - where pterm = ifM (enableDH <$> getState) (multterm lit) (term lit) +tupleterm :: Ord l => Parser (Term l) -> Parser (Term l) +tupleterm plit = chainr1 (multterm plit) ((\a b -> fAppPair (a,b))<$ kw COMMA) -- | Parse a fact. -fact :: Parser (Term l) -> Parser (Fact (Term l)) -fact lit = +fact :: Ord l => Parser (Term l) -> Parser (Fact (Term l)) +fact plit = do multi <- option Linear (kw BANG *> pure Persistent) i <- identifier case i of [] -> fail "empty identifier" (c:_) | isUpper c -> return () | otherwise -> fail "facts must start with upper-case letters" - ts <- parens (sepBy (multterm lit) (kw COMMA)) + ts <- parens (sepBy (multterm plit) (kw COMMA)) mkProtoFact multi i ts "protocol fact" where @@ -384,6 +393,7 @@ "IN" -> singleTerm f inFact "KU" -> return . Fact KUFact "KD" -> return . Fact KDFact + "DED" -> return . Fact DedFact "FR" -> singleTerm f freshFact _ -> return . protoFact multi f @@ -421,9 +431,18 @@ protoRule :: Parser (ProtoRuleE) protoRule = do name <- try (string "rule" *> optional moduloE *> identifier <* kw COLON) + subst <- option emptySubst letBlock (ps,as,cs) <- genericRule - return $ Rule (StandRule name) ps cs as + return $ apply subst $ Rule (StandRule name) ps cs as +-- | Parse a let block with bottom-up application semantics. +letBlock :: Parser LNSubst +letBlock = do + toSubst <$> (string "let" *> many1 definition <* string "in") + where + toSubst = foldr1 compose . map (substFromList . return) + definition = (,) <$> (sortedLVar [LSortMsg] <* kw EQUAL) <*> multterm llit + -- | Parse an intruder rule. intrRule :: Parser IntrRuleAC intrRule = do @@ -433,9 +452,10 @@ where intrInfo = do name <- identifier - if map toUpper name == "COERCE" - then return $ CoerceRule - else return $ IntrApp name + case name of + 'c':cname -> return $ ConstrRule cname + 'd':dname -> return $ DestrRule dname + _ -> fail $ "invalid intruder rule name '" ++ name ++ "'" genericRule :: Parser ([LNFact], [LNFact], [LNFact]) genericRule = @@ -627,18 +647,20 @@ -- | Parse an atom with possibly bound logical variables. blatom :: Parser BLAtom -blatom = (fmap (fmap (fmap Free))) <$> asum +blatom = (fmap (fmapTerm (fmap Free))) <$> asum [ flip Action <$> try (fact llit <* actionOp) <*> nodevarTerm "action" , Less <$> try (nodevarTerm <* lessOp) <*> nodevarTerm "less" , DedBefore <$> try (term llit <* dedBeforeOp) <*> nodevarTerm "deduced before" - , EdgeA <$> try (nodePrem <* edgeOp) <*> nodeConc "edge" + , EdgeA <$> try (nodeConc <* edgeOp) <*> nodePrem "edge" , EqE <$> try (multterm llit <* equalOp) <*> multterm llit "term equality" , EqE <$> (nodevarTerm <* equalOp) <*> nodevarTerm "node equality" ] where - nodevarTerm = (Lit . Var) <$> nodevar - nodePrem = parens ((,) <$> (nodevarTerm <* kw COMMA) <*> integer) - nodeConc = nodePrem + nodevarTerm = (lit . Var) <$> nodevar + nodePrem = annNode PremIdx + nodeConc = annNode ConcIdx + annNode mkAnn = parens ((,) <$> (nodevarTerm <* kw COMMA) + <*> (mkAnn <$> integer)) -- | Parse an atom of a formula. fatom :: Parser (LFormula Name) @@ -679,7 +701,7 @@ imp = do lhs <- disjuncts asum [ try (kw EQUAL *> kw EQUAL *> kw GREATER) *> - ((lhs .==>.) <$> disjuncts) + ((lhs .==>.) <$> imp) , pure lhs ] -- | An logical equivalence. @@ -690,18 +712,27 @@ ((lhs .<=>.) <$> imp) , pure lhs ] --- | Parse a lemma attribute. +-- | Parse a 'LemmaAttribute'. lemmaAttribute :: Parser LemmaAttribute lemmaAttribute = asum - [ string "typing" *> pure TypingLemma - , string "reuse" *> pure ReuseLemma + [ string "typing" *> pure TypingLemma + , string "reuse" *> pure ReuseLemma + , string "invariant" *> pure InvariantLemma ] +-- | Parse a 'TraceQuantifier'. +traceQuantifier :: Parser TraceQuantifier +traceQuantifier = asum + [ string "all" *> kw MINUS *> string "traces" *> pure AllTraces + , string "exists" *> kw MINUS *> string "trace" *> pure ExistsTrace + ] + -- | Parse a lemma. lemma :: Parser (Lemma ProofSkeleton) lemma = skeletonLemma <$> (string "lemma" *> optional moduloE *> identifier) <*> (option [] $ list lemmaAttribute) - <*> (kw COLON *> doubleQuoted iff) + <*> (kw COLON *> option AllTraces traceQuantifier) + <*> doubleQuoted iff <*> (proofSkeleton <|> pure (unproven ())) @@ -717,9 +748,9 @@ factSymbol = ProtoFact Linear <$> identifier <*> (kw SLASH *> integer) -builtin :: Parser () -builtin = - string "builtin" *> kw COLON *> sepBy1 builtinTheory (kw COMMA) *> pure () +builtins :: Parser () +builtins = + string "builtins" *> kw COLON *> sepBy1 builtinTheory (kw COMMA) *> pure () where extendSig msig = modifyState (`mappend` msig) builtinTheory = asum @@ -740,14 +771,14 @@ string "functions" *> kw COLON *> sepBy1 functionSymbol (kw COMMA) *> pure () where functionSymbol = do - funsym <- (,) <$> identifier <*> (kw SLASH *> integer) + funsym <- (,) <$> (BC.pack <$> identifier) <*> (kw SLASH *> integer) sig <- getState - case lookup (fst funsym) (funSig sig) of + case lookup (fst funsym) (S.toList $ allFunctionSymbols sig) of Just k | k /= snd funsym -> fail $ "conflicting arities " ++ show k ++ " and " ++ show (snd funsym) ++ - " for `" ++ fst funsym - _ -> setState (sig `mappend` emptyMaudeSig {funSig = [funsym]}) + " for `" ++ BC.unpack (fst funsym) + _ -> setState (addFunctionSymbol funsym sig) equations :: Parser () equations = @@ -757,7 +788,7 @@ rrule <- RRule <$> term llit <*> (kw EQUAL *> term llit) case rRuleToStRule rrule of Just str -> - modifyState (`mappend` emptyMaudeSig {stRules = [str]}) + modifyState (addStRule str) Nothing -> fail $ "Not a subterm rule: " ++ show rrule @@ -781,7 +812,7 @@ [ do fresh <- globallyFresh addItems flags $ modify (sigpUniqueInsts . thySignature) (S.union fresh) thy - , do builtin + , do builtins msig <- getState addItems flags $ set (sigpMaudeSig . thySignature) msig thy , do functions diff --git a/src/Theory/Proof.hs b/src/Theory/Proof.hs --- a/src/Theory/Proof.hs +++ b/src/Theory/Proof.hs @@ -25,8 +25,10 @@ , insertPaths -- ** Folding/modifying proofs + , mapProofInfo , foldProof - , ProofStatus + , annotateProof + , ProofStatus(..) , proofStepStatus , cutOnAttackDFS @@ -58,6 +60,7 @@ , contradictionAndClauseProver -- ** Pretty Printing + , simplifyVariableIndices , prettyProofMethod , prettyProof , prettyProofWith @@ -90,11 +93,11 @@ import Control.Basics import qualified Control.Monad.State as S +import Control.Monad.Bind +import qualified Control.Monad.Trans.PreciseFresh as Precise import Control.Parallel.Strategies import Control.DeepSeq -import Text.Isar - import Theory.Pretty import Theory.Proof.CaseDistinctions @@ -263,6 +266,9 @@ instance Traversable ProofStep where traverse f (ProofStep m i) = ProofStep m <$> f i +instance HasFrees a => HasFrees (ProofStep a) where + foldFrees f (ProofStep m i) = foldFrees f m `mappend` foldFrees f i + mapFrees f (ProofStep m i) = ProofStep <$> mapFrees f m <*> mapFrees f i ------------------------------------------------------------------------------ -- Proof Trees @@ -344,6 +350,16 @@ where go (LNode step cs) = f step `mappend` foldMap go (M.elems cs) +-- | Annotate a proof in a bottom-up fashion. +annotateProof :: (ProofStep a -> [b] -> b) -> Proof a -> Proof b +annotateProof f = + go + where + go (LNode step@(ProofStep method _) cs) = + LNode (ProofStep method info') cs' + where + cs' = M.map go cs + info' = f step (map (psInfo . root . snd) (M.toList cs')) -- Proof cutting ---------------- @@ -352,20 +368,20 @@ data ProofStatus = CompleteProof -- ^ The proof is complete: no sorry, no attack | IncompleteProof -- ^ There is a sorry, but no attack. - | AttackFound -- ^ There is an attack + | TraceFound -- ^ There is an attack instance Monoid ProofStatus where mempty = CompleteProof - mappend AttackFound _ = AttackFound - mappend _ AttackFound = AttackFound + mappend TraceFound _ = TraceFound + mappend _ TraceFound = TraceFound mappend IncompleteProof _ = IncompleteProof mappend _ IncompleteProof = IncompleteProof mappend CompleteProof CompleteProof = CompleteProof -- | The status of a 'ProofStep'. proofStepStatus :: ProofStep a -> ProofStatus -proofStepStatus (ProofStep Attack _) = AttackFound +proofStepStatus (ProofStep Attack _) = TraceFound proofStepStatus (ProofStep (Sorry _) _) = IncompleteProof proofStepStatus (ProofStep _ _) = CompleteProof @@ -404,17 +420,17 @@ case S.runState (checkLevel l prf) CompleteProof of (_, CompleteProof) -> prf (_, IncompleteProof) -> go (l+1) prf - (prf', AttackFound) -> + (prf', TraceFound) -> trace ("attack found at depth: " ++ show l) prf' checkLevel 0 (LNode step@(ProofStep Attack _) _) = - S.put AttackFound >> return (LNode step M.empty) + S.put TraceFound >> return (LNode step M.empty) checkLevel 0 prf@(LNode (ProofStep _ x) cs) | M.null cs = return prf | otherwise = do st <- S.get msg <- case st of - AttackFound -> return $ "ignored (attack exists)" + TraceFound -> return $ "ignored (attack exists)" _ -> S.put IncompleteProof >> return "bound reached" return $ LNode (ProofStep (Sorry msg) x) M.empty checkLevel l (LNode step cs) = @@ -454,8 +470,9 @@ [se'] | check se se' -> return $ M.singleton "" se' | otherwise -> mzero ses -> - error $ "execMethod: unexpected number of sequents: " ++ show (length ses) ++ - render (nest 2 $ vcat $ map ((text "" $-$) . prettySequent) ses) + return $ M.fromList (zip (map show [(1::Int)..]) ses) +-- error $ "execMethod: unexpected number of sequents: " ++ show (length ses) ++ +-- render (nest 2 $ vcat $ map ((text "" $-$) . prettySequent) ses) -- solve the given goal -- PRE: Goal must be valid in this sequent. @@ -499,14 +516,13 @@ emptySequent (L.get sCaseDistKind se) -- | A list of possibly applicable proof methods. -possibleProofMethods :: SignatureWithMaude -> Sequent -> [ProofMethod] -possibleProofMethods sig se = - ((Contradiction . Just) <$> contradictions sig se) - -- For now (12/01/22), we add induction after simplification to ensure - -- that the autoprover doesn't use induction. (Induction can only be - -- executed in a sequent that contains exactly one formula eligible for - -- induction.) - <|> [Simplify, Induction] +possibleProofMethods :: ProofContext -> Sequent -> [ProofMethod] +possibleProofMethods ctxt se = + ((Contradiction . Just) <$> contradictions (L.get pcSignature ctxt) se) + <|> (case L.get pcUseInduction ctxt of + AvoidInduction -> [Simplify, Induction] + UseInduction -> [Induction, Simplify] + ) <|> (SolveGoal <$> openGoals se) -- | @proveSequentDFS rules se@ tries to construct a proof that @se@ is valid @@ -522,7 +538,7 @@ where (method, cases) = headDef (Attack, M.empty) $ do - m <- possibleProofMethods (L.get pcSignature ctxt) se + m <- possibleProofMethods ctxt se (m,) <$> maybe mzero return (execProofMethod ctxt m se) @@ -560,8 +576,11 @@ -> Proof (Maybe a, Maybe Sequent) checkProof ctxt prover se (LNode (ProofStep method info) cs) = fromMaybe (node method (M.map noSequentPrf cs)) $ headMay $ do - method' <- method : possibleProofMethods (L.get pcSignature ctxt) se - guard (method `eqModuloFreshness` method') + method' <- method : possibleProofMethods ctxt se + -- FIXME: eqModuloFreshness is too strict currently as it doesn't + -- rename variables to a canonical representative. Moreover, it screws + -- up if there are AC symbols involved. + guard (method `eqModuloFreshnessNoAC` method') cases <- maybe mzero return $ execProofMethod ctxt method' se return $ node method' $ checkChildren cases @@ -578,6 +597,7 @@ unhandledCase = mapProofInfo ((,) Nothing) . prover + ------------------------------------------------------------------------------ -- Provers: the interface to the outside world. ------------------------------------------------------------------------------ @@ -606,7 +626,7 @@ -- | Map the proof generated by the prover. mapProverProof :: (IncrementalProof -> IncrementalProof) -> Prover -> Prover -mapProverProof f p = Prover $ \ rules se prf -> f<$> runProver p rules se prf +mapProverProof f p = Prover $ \ rules se prf -> f <$> runProver p rules se prf -- | Prover that always fails. failProver :: Prover @@ -693,6 +713,19 @@ -- Pretty printing ------------------------------------------------------------------------------ +-- | Consistently simplify variable indices in the proof; i.e., rename all +-- free variables in a top-down fashion using the 'Precise.FreshT' +-- transformer. +simplifyVariableIndices :: HasFrees a => Proof a -> Proof a +simplifyVariableIndices = + go noBindings Precise.nothingUsed + where + go bindSt freshSt (LNode step cs) = + case Precise.runFresh (runBindT (someInst step) bindSt) freshSt of + ((step', bindSt'), freshSt') -> + LNode step' (M.map (go bindSt' freshSt') cs) + + prettyContradiction :: Document d => Contradiction -> d prettyContradiction contra = case contra of Cyclic -> text "cyclic" @@ -708,7 +741,7 @@ prettyProofMethod :: HighlightDocument d => ProofMethod -> d prettyProofMethod method = case method of - Attack -> keyword_ "SOLVED (trace found)" + Attack -> keyword_ "SOLVED" <-> lineComment_ "trace found" Induction -> keyword_ "induction" Sorry reason -> fsep [keyword_ "sorry", lineComment_ reason] SolveGoal goal -> hsep [keyword_ "solve(", prettyGoal goal, keyword_ ")"] @@ -745,10 +778,12 @@ ppPrf prf -- | Convert a proof status to a redable string. -showProofStatus :: ProofStatus -> String -showProofStatus AttackFound = "attack found" -showProofStatus IncompleteProof = "incomplete proof" -showProofStatus CompleteProof = "complete proof" +showProofStatus :: SequentTraceQuantifier -> ProofStatus -> String +showProofStatus ExistsNoTrace TraceFound = "falsified - found trace" +showProofStatus ExistsNoTrace CompleteProof = "verified" +showProofStatus ExistsSomeTrace CompleteProof = "falsified - no trace found" +showProofStatus ExistsSomeTrace TraceFound = "verified" +showProofStatus _ IncompleteProof = "analysis incomplete" -- Derived instances diff --git a/src/Theory/Proof/CaseDistinctions.hs b/src/Theory/Proof/CaseDistinctions.hs --- a/src/Theory/Proof/CaseDistinctions.hs +++ b/src/Theory/Proof/CaseDistinctions.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable, TupleSections, TypeOperators #-} -{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, TupleSections, TypeOperators, + TemplateHaskell, TypeSynonymInstances, FlexibleInstances, + FlexibleContexts, GeneralizedNewtypeDeriving, ViewPatterns + #-} -- | -- Copyright : (c) 2011,2012 Simon Meier -- License : GPL v3 (see LICENSE) @@ -32,21 +33,19 @@ import Safe import Prelude hiding ( (.), id ) -import Debug.Trace import qualified Data.Set as S -import qualified Data.DAG.Simple as D import Data.Foldable (asum) import Control.Basics import Control.Category import Control.Monad.Disj -import Control.Monad.Bind +-- import Control.Monad.Bind import Control.Monad.Reader import Control.Monad.State (gets) import Control.Parallel.Strategies -import Text.Isar +import Text.PrettyPrint.Highlight import Extension.Prelude import Extension.Data.Label @@ -55,22 +54,6 @@ import Theory.Proof.Sequent --- | AC-Matching for big-step goals. MessageBigSteps can be matched --- to the corresponding K-up facts. -matchBigStepGoal :: BigStepGoal -- ^ Term. - -> BigStepGoal -- ^ Pattern. - -> WithMaude [LNSubst] -matchBigStepGoal (PremiseBigStep faTerm) (PremiseBigStep faPat) = - matchLNFact faTerm faPat -matchBigStepGoal (MessageBigStep mTerm) (MessageBigStep mPat) = - matchLNTerm [mTerm `MatchWith` mPat] -matchBigStepGoal (MessageBigStep mTerm) (PremiseBigStep faPat) = - case kFactView faPat of - Just (UpK, _, mPat) -> matchLNTerm [mTerm `MatchWith` mPat] - _ -> return [] -matchBigStepGoal _ _ = return [] - - ------------------------------------------------------------------------------ -- Big Step Proofs ------------------------------------------------------------------------------ @@ -88,35 +71,23 @@ -- given typing assumptions are justified. initialCaseDistinction :: ProofContext -> [LNGuarded] -- ^ Typing assumptions. - -> BigStepGoal -> CaseDistinction -initialCaseDistinction ctxt typAsms goal = - CaseDistinction goal cases + -> LNFact -> CaseDistinction +initialCaseDistinction ctxt typAsms goalFa = + CaseDistinction goalFa cases where polish (((name, prem), se), _) = ([name], (prem, se)) se0 = set sFormulas (S.fromList typAsms) (emptySequent UntypedCaseDist) - cases = fmap polish $ runSeProof instantiate ctxt se0 (avoid (goal, se0)) + cases = fmap polish $ runSeProof instantiate ctxt se0 (avoid (goalFa, se0)) instantiate = do i <- freshLVar "i" LSortNode - let p = NodePrem (i, 0) + let p = (i, PremIdx 0) err = error . ("requiresCasesThm: no or too many edges: " ++) - case goal of - PremiseBigStep fa -> do - name <- solveGoal (PremiseG p fa) - edges <- getM sEdges - case filter ((p ==) . eTgt) (S.toList edges) of - [e] -> do modM sEdges (S.delete e) - return (name, eSrc e) - es -> err $ show es - - -- FIXME: Probably this code is not required. - MessageBigStep m -> do - name <- solveGoal (PremUpKG p m) - edges <- getM sMsgEdges - case filter ((p ==) . meTgt) (S.toList edges) of - [e] -> do modM sMsgEdges (S.delete e) - return (name, meSrc e) - es -> err $ show es - + name <- solveGoal (PremiseG p goalFa False) + edges <- getM sEdges + case filter ((p ==) . eTgt) (S.toList edges) of + [e] -> do modM sEdges (S.delete e) + return (name, eSrc e) + es -> err $ show es -- | Refine a source case distinction by applying the additional proof step. refineCaseDistinction @@ -144,26 +115,22 @@ -- repeatedly simplifying the proof state. -- -- Returns the names of the steps applied. -solveAllSafeGoals - :: (LNFact -> Bool) -- ^ True, if this fact may be refined further. - -- Required for loop-breaking. - -> [CaseDistinction] - -> SeProof [String] -solveAllSafeGoals nonLoopingFact ths = +solveAllSafeGoals :: [CaseDistinction] -> SeProof [String] +solveAllSafeGoals ths = solve [] where - safeGoal _ (ChainG _) = True - safeGoal _ (PremDnKG _) = True - safeGoal _ (ActionG _ _) = True - safeGoal splitAllowed (DisjG _) = splitAllowed + safeGoal _ (ChainG _) = True + safeGoal _ (PremDnKG _) = True + safeGoal _ (ActionG _ _) = True + safeGoal splitAllowed (DisjG _) = splitAllowed -- NOTE: Uncomment the line below to get more extensive case splitting -- for precomputed case distinctions. -- safeGoal splitAllowed (SplitG _ _) = splitAllowed - safeGoal _ (PremiseG _ fa) = nonLoopingFact fa - safeGoal _ _ = False + safeGoal _ (PremiseG _ fa mayLoop) = not (mayLoop || isKFact fa) + safeGoal _ _ = False - nonLoopingGoal (PremiseG _ fa) = nonLoopingFact fa - nonLoopingGoal _ = True + nonLoopingGoal (PremiseG _ _ mayLoop) = not mayLoop + nonLoopingGoal _ = True solve caseNames = do simplifySequent @@ -188,48 +155,85 @@ Nothing -> return $ caseNames Just step -> solve . (caseNames ++) =<< step --- | Try to solve a premise goal using the first precomputed case distinction --- with a matching premise. + +------------------------------------------------------------------------------ +-- Applying precomputed case distinctions +------------------------------------------------------------------------------ + +-- | A goal for a big step case distinction. +data BigStepGoal = + PremiseBigStep NodePrem LNFact Bool + | MessageBigStep (Either NodeId NodePrem) LNTerm + -- ^ Left means solving a deduction action, Right a node premise. + deriving( Eq, Ord, Show ) + +-- | Convert a standard goal to a big-step goal. +toBigStepGoal :: Goal -> Maybe BigStepGoal +toBigStepGoal goal = case goal of + PremiseG p fa mayLoop -> return $ PremiseBigStep p fa mayLoop + PremUpKG p m -> return $ MessageBigStep (Right p) m + ActionG i (dedFactView -> Just m) -> return $ MessageBigStep (Left i) m + _ -> mzero + +fromBigStepGoal :: BigStepGoal -> Goal +fromBigStepGoal goal = case goal of + PremiseBigStep p fa mayLoop -> PremiseG p fa mayLoop + MessageBigStep (Left i) m -> ActionG i (dedLogFact m) + MessageBigStep (Right p) m -> PremUpKG p m + + +-- | AC-Matching for big-step goals. MessageBigSteps can be matched +-- to the corresponding K-up facts. +matchBigStepGoal :: BigStepGoal -- ^ Term. + -> LNFact -- ^ Pattern. + -> WithMaude [LNSubst] +matchBigStepGoal (PremiseBigStep _ faTerm _) faPat = matchLNFact faTerm faPat +matchBigStepGoal (MessageBigStep _ mTerm) faPat = + case kFactView faPat of + Just (UpK, _, mPat) -> matchLNTerm [mTerm `MatchWith` mPat] + _ -> return [] + +-- | Try to solve a premise goal or 'Ded' action using the first precomputed +-- case distinction with a matching premise. solveWithCaseDistinction :: MaudeHandle -> [CaseDistinction] -> Goal -> Maybe (SeProof [String]) -solveWithCaseDistinction hnd ths goal0 = case goal0 of - PremiseG p fa -> applyTo p (PremiseBigStep fa) - PremUpKG p m -> applyTo p (MessageBigStep m) - _ -> mzero - where - applyTo p goal = asum [ applyCaseDistinction hnd th p goal | th <- ths ] +solveWithCaseDistinction hnd ths goal0 = do + goal <- toBigStepGoal goal0 + asum [ applyCaseDistinction hnd th goal | th <- ths ] -- | Apply a precomputed case distinction theorem to a required fact. applyCaseDistinction :: MaudeHandle - -> CaseDistinction -- ^ Case distinction theorem. - -> NodePrem -- ^ Premise + -> CaseDistinction -- ^ Case distinction theorem. -> BigStepGoal -- ^ Required goal -> Maybe (SeProof [String]) -applyCaseDistinction hnd th prem goal = +applyCaseDistinction hnd th goal = case (`runReader` hnd) $ matchBigStepGoal goal (get cdGoal th) of [] -> Nothing - _ -> Just $ do (names, subst, seTh) <- instTheorem `evalBindT` noBindings + _ -> Just $ do (names, subst, seTh) <- instTheorem solveSubstEqs SplitNow subst conjoinSequent seTh return names where - instTheorem :: BindT LVar LVar SeProof ([String], LNSubst, Sequent) + instTheorem :: SeProof ([String], LNSubst, Sequent) instTheorem = do - goalTh <- someInst $ get cdGoal th + instTh <- rename th -- We only have to choose one matcher, as the theorem holds for all -- premises equal modulo AC. subst <- disjunctionOfList $ take 1 $ - matchBigStepGoal goal goalTh `runReader` hnd - (names, (concTh, seTh)) <- someInst =<< - (disjunctionOfList $ getDisj $ get cdCases th) + matchBigStepGoal goal (get cdGoal instTh) `runReader` hnd + (names, (concTh, seTh)) <- disjunctionOfList $ getDisj $ get cdCases instTh - let seTh' = case goal of - PremiseBigStep _ -> - modify sEdges (S.insert (Edge concTh prem)) seTh - MessageBigStep _ -> - modify sMsgEdges (S.insert (MsgEdge concTh prem)) seTh + seTh' <- case goal of + PremiseBigStep prem _ _ -> + return $ modify sEdges (S.insert (Edge concTh prem)) seTh + MessageBigStep (Right prem) _ -> + return $ modify sMsgEdges (S.insert (MsgEdge concTh prem)) seTh + MessageBigStep (Left i) m -> do + -- remove solved atom + modM sAtoms (S.delete (Action (varTerm i) (dedLogFact m))) + return seTh -- solving the matcher equalities and -- conjoining the sequent will be done later @@ -243,8 +247,6 @@ saturateCaseDistinctions ctxt = go where - nonLoopingFact = saturationLoopBreakers ctxt - go ths = if any or (changes `using` parList rdeepseq) then go ths' @@ -252,7 +254,7 @@ where (changes, ths') = unzip $ map (refineCaseDistinction ctxt solver) ths noSplitThs = filter ((<= 1) . length . getDisj . get cdCases) ths - solver = do names <- solveAllSafeGoals nonLoopingFact noSplitThs + solver = do names <- solveAllSafeGoals noSplitThs return (not $ null names, names) {- @@ -294,18 +296,18 @@ absFact (Fact tag ts) = (tag, length ts) - nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..n] ] + nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..fromIntegral n] ] - someProtoGoal :: (FactTag, Int) -> BigStepGoal - someProtoGoal (tag, arity) = PremiseBigStep $ Fact tag (nMsgVars arity) + someProtoGoal :: (FactTag, Int) -> LNFact + someProtoGoal (tag, arity) = Fact tag (nMsgVars arity) - someKUGoal :: LNTerm -> BigStepGoal - someKUGoal m = PremiseBigStep (Fact KUFact [varTerm (LVar "f_" LSortMsg 0), m]) + someKUGoal :: LNTerm -> LNFact + someKUGoal m = Fact KUFact [varTerm (LVar "f_" LSortMsg 0), m] -- FIXME: Also use facts from proof context. rules = get pcRules ctxt absProtoFacts = sortednub $ do - ru <- joinNonSpecialRules rules + ru <- joinAllRules rules fa <- absFact <$> (getProtoFact =<< (get rConcs ru ++ get rPrems ru)) -- exclude facts handled specially by the prover guard (not $ fst fa `elem` [OutFact, InFact, FreshFact]) @@ -313,11 +315,11 @@ absMsgFacts :: [LNTerm] absMsgFacts = asum $ sortednub $ - [ do return $ Lit $ Var (LVar "t" LSortFresh 1) + [ do return $ lit $ Var (LVar "t" LSortFresh 1) - , [ FApp (NonAC (s,k)) $ nMsgVars k - | (s,k) <- funSigForMaudeSig . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt - , s `notElem` [ "inv", "pair" ] ] + , [ fAppNonAC (s,k) $ nMsgVars k + | (s,k) <- S.toList . allFunctionSymbols . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt + , (s,k) `S.notMember` implicitFunSig, k > 0 ] ] -- | Refine a set of case distinction by exploiting additional typing @@ -338,51 +340,11 @@ set sCaseDistKind TypedCaseDist $ se removeFormulas = set sFormulas S.empty . set sSolvedFormulas S.empty --- Loop-breaker computation ---------------------------- - --- | Compute the loop-breakers for saturating the pre-computated case --- distinctions. -saturationLoopBreakers :: ProofContext -> (LNFact -> Bool) -saturationLoopBreakers ctxt = - trace (" loop breakers: " ++ show (loopBreakers absProtoFactRel)) $ - \fa -> absFact fa `S.notMember` loopBreakers absProtoFactRel - where - rules = get pcRules ctxt - -- detect cycles on abstracted protocol facts; i.e., (tag, arity) facts - absFact (Fact tag ts) = (tag, length ts) - - absProtoFactRel = sortednub $ do - ru <- joinNonSpecialRules rules - conc <- absFact <$> get rConcs ru - prem <- absFact <$> get rPrems ru - return (conc, prem) - - --- | Given a relation compute a set of loop-breakers; i.e., a feedback vertex --- set (). No guarantee for --- minimality is made. The current algorithm only removes self-loops and hopes --- that this is sufficient. We should implement something along the lines of --- Ann Becker, Dan Geiger, Optimization of Pearl's method of conditioning and --- greedy-like approximation algorithms for the vertex feedback set problem, --- Artificial Intelligence, Volume 83, Issue 1, May 1996, Pages 167-188, ISSN --- 0004-3702, 10.1016/0004-3702(95)00004-6. --- . -loopBreakers :: Ord a => [(a,a)] -> S.Set a -loopBreakers rel - | D.cyclic rel' = - error "loopBreakers: trivial loop-breaker computation failed.\ - \The relation is still cyclic." - | otherwise = breakers - where - breakers = S.fromList [ x | (x, y) <- rel, x == y ] - rel' = [ r | r@(x, y) <- rel - , x `S.notMember` breakers, y `S.notMember` breakers] - ------------------------------------------------------------------------------ -- Pretty-printing ------------------------------------------------------------------------------ -prettyBigStepGoal :: Document d => BigStepGoal -> d -prettyBigStepGoal (PremiseBigStep fa) = prettyLNFact fa -prettyBigStepGoal (MessageBigStep m) = prettyLNTerm m +prettyBigStepGoal :: HighlightDocument d => BigStepGoal -> d +prettyBigStepGoal = prettyGoal . fromBigStepGoal + + diff --git a/src/Theory/Proof/EquationStore.hs b/src/Theory/Proof/EquationStore.hs --- a/src/Theory/Proof/EquationStore.hs +++ b/src/Theory/Proof/EquationStore.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TypeOperators, TemplateHaskell, DeriveDataTypeable, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE TypeOperators, TemplateHaskell, DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables, TupleSections, ViewPatterns #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt -- License : GPL v3 (see LICENSE) @@ -15,6 +16,7 @@ , addRuleVariants , splitAtPos , eqSplits + , splitCasenum , constrainedVarsPos , SplitStrategy(..) @@ -33,16 +35,15 @@ import Utils.Misc import Extension.Prelude --- import qualified Debug.Trace as DT - import Debug.Trace.Ignore import Data.List import Data.Label hiding ( for ) import Data.Maybe +import Safe import Data.Monoid -import Data.Traversable hiding ( mapM ) import qualified Data.Foldable as F +import qualified Data.Set as S import Control.Basics import Control.Monad.State hiding (get, modify) import qualified Control.Monad.State as MS @@ -51,19 +52,49 @@ -- Equation Store ---------------------------------------------------------------------- --- | We use an empty disjunction to denote false. -falseDisj :: Disj (LNSubstVFresh) -falseDisj = Disj [] +-- | We use the empty set (disjunction) to denote false. +falseDisj :: S.Set LNSubstVFresh +falseDisj = S.empty +-- | 'SplitStrategy' denotes if the equation store should be split into +-- multiple equation stores. data SplitStrategy = SplitNow | SplitLater -- Dealing with equations ---------------------------------------------------------------------- --- | Returns the list of all @SplitId@s corresponding equation disjunctions. +-- | Returns the list of all @SplitId@s valid for the given equation store +-- sorted by the size of the disjunctions. eqSplits :: EqStore -> [SplitId] -eqSplits eqs = [0.. length (getConj . get eqsConj $ eqs) -1 ] +eqSplits eqs = + map fst . sortOn snd $ zip [0..] (map S.size . getConj . get eqsConj $ eqs) + +-- | Returns the number of cases for a given 'SplitId'. +splitCasenum :: EqStore -> SplitId -> Int +splitCasenum eqs sid = case atMay (getConj . get eqsConj $ eqs) sid of + Just disj -> S.size disj + Nothing -> error "splitCasenum: invalid split id" + + +-- | Add a disjunction to the equation store at the beginning +addDisj :: EqStore -> (S.Set LNSubstVFresh) -> EqStore +addDisj eqStore disj = modify eqsConj ((Conj [disj]) `mappend`) eqStore + + +-- | @splitEqStoreAt eqs i@ takes the disjunction at position @i@ in @eqs@ +-- and returns a list of resulting substitutions and the equality store +-- with the remaining equations. +splitAtPos :: EqStore -> Int -> Maybe [EqStore] +splitAtPos eqStore i + | i `notElem` eqSplits eqStore = Nothing + | otherwise = Just $ map (\d -> set eqsConj (conjNew d) eqStore) disj + where + conj = getConj $ get eqsConj eqStore + disj = S.toList (conj !! i) + conjNew d = Conj $ take i conj ++ [ S.singleton d ] ++ drop (i+1) conj + + -- | Add a list of term equalities to the equation store. -- Returns the resulting equation store(s) depending -- on the split strategy. @@ -71,35 +102,38 @@ -> [Equal LNTerm] -> EqStore -> m [EqStore] addEqs splitStrat hnd eqs0 eqStore = case unifyLNTermFactored eqs `runReader` hnd of - (_, []) -> return [set eqsConj falseEqConstrConj eqStore] - (subst, substs) -> - case splitStrat of - SplitLater -> - return $ [addDisj (applyEqStore hnd subst eqStore) (Disj substs)] - SplitNow -> - addEqsAC (modify eqsSubst (compose subst) eqStore) - <$> simpDisjunction hnd (Disj substs) + (_, []) -> return [ set eqsConj falseEqConstrConj eqStore ] + (subst, [ substFresh ]) | substFresh == emptySubstVFresh -> + return [ applyEqStore hnd subst eqStore ] + (subst, substs) -> + case splitStrat of + SplitLater -> + return [ addDisj (applyEqStore hnd subst eqStore) (S.fromList substs) ] + SplitNow -> + addEqsAC (modify eqsSubst (compose subst) eqStore) + <$> simpDisjunction hnd (const False) (Disj substs) where eqs = apply (get eqsSubst eqStore) $ trace (unlines ["addEqs: ", show eqs0]) $ eqs0 - addEqsAC eqSt (sfree, Nothing) = [applyEqStore hnd sfree eqSt] + addEqsAC eqSt (sfree, Nothing) = [ applyEqStore hnd sfree eqSt ] addEqsAC eqSt (sfree, Just disj) = fromMaybe (error "addEqsSplit: impossible, splitAtPos failed") - (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (Disj disj))) 0) + (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (S.fromList disj))) 0) + -- | Apply a substitution to an equation store and bring resulting equations into -- normal form again by using unification. applyEqStore :: MaudeHandle -> LNSubst -> EqStore -> EqStore applyEqStore hnd asubst eqStore | dom asubst `intersect` varsRange asubst /= [] || trace (show ("applyEqStore", asubst, eqStore)) False - = error $ "applyS2EqStore: dom and vrange not disjoint for `"++show asubst++"'" + = error $ "applyEqStore: dom and vrange not disjoint for `"++show asubst++"'" | otherwise - = modify eqsConj (fmap ((Disj . concatMap applyBound . getDisj))) $ - set eqsSubst newsubst eqStore + = modify eqsConj (fmap (S.fromList . concatMap applyBound . S.toList)) $ + set eqsSubst newsubst eqStore where newsubst = asubst `compose` get eqsSubst eqStore applyBound s = map (restrictVFresh (varsRange newsubst ++ domVFresh s)) $ (`runReader` hnd) $ unifyLNTerm - [ Equal (apply newsubst (varTerm $ lv)) t + [ Equal (apply newsubst (varTerm lv)) t | let slist = substToListVFresh s, -- variables in the range are fresh, so we have to rename -- them away from all other variables in unification problem @@ -133,15 +167,16 @@ -} -- | Add the given rule variants. -addRuleVariants :: (Disj (LNSubstVFresh)) -> EqStore -> EqStore +addRuleVariants :: Disj LNSubstVFresh -> EqStore -> EqStore addRuleVariants (Disj substs) eqStore | dom freeSubst `intersect` concatMap domVFresh substs /= [] = error $ "addRuleVariants: Nonempty intersection between domain of variants and free substitution. " ++"This case has not been implemented, add rule variants earlier." - | otherwise = addDisj eqStore (Disj substs) + | otherwise = addDisj eqStore (S.fromList substs) where freeSubst = get eqsSubst eqStore + -- | Return the set of variables that is constrained by disjunction at give position. constrainedVarsPos :: EqStore -> Int -> [LVar] constrainedVarsPos eqStore k @@ -150,26 +185,6 @@ where conj = getConj . get eqsConj $ eqStore --- Internal functions ----------------------------------------------------------------------- - --- | Add a disjunction to the equation store at the beginning -addDisj :: EqStore -> (Disj (LNSubstVFresh)) -> EqStore -addDisj eqStore disj = modify eqsConj ((Conj [disj]) `mappend`) eqStore - - --- | @splitEqStoreAt eqs i@ takes the disjunction at position @i@ in @eqs@ --- and returns a list of resulting substitutions and the equality store --- with the remaining equations. -splitAtPos :: EqStore -> Int -> Maybe [EqStore] -splitAtPos eqStore i - | i `notElem` eqSplits eqStore = Nothing - | otherwise = Just $ map (\d -> set eqsConj (conjNew d) eqStore) disj - where - conj = getConj $ get eqsConj eqStore - disj = getDisj $ conj !! i - conjNew d = Conj $ take i conj ++ [Disj [d]] ++ drop (i+1) conj - -- Simplifying disjunctions ---------------------------------------------------------------------- @@ -177,59 +192,59 @@ -- names for variables from the underlying 'MonadFresh'. simpDisjunction :: MonadFresh m => MaudeHandle - -> Disj (LNSubstVFresh) + -> (LNSubstVFresh -> Bool) + -> Disj LNSubstVFresh -> m (LNSubst, Maybe [LNSubstVFresh]) -simpDisjunction hnd disj0 = do - eqStore' <- simp hnd eqStore +simpDisjunction hnd isContr disj0 = do + eqStore' <- simp hnd isContr eqStore return (get eqsSubst eqStore', wrap $ get eqsConj eqStore') where - eqStore = set eqsConj (Conj [disj0]) $ emptyEqStore - wrap (Conj []) = Nothing - wrap (Conj [Disj disj]) = Just $ disj - wrap conj = + eqStore = set eqsConj (Conj [ S.fromList . getDisj $ disj0 ]) $ emptyEqStore + wrap (Conj []) = Nothing + wrap (Conj [disj]) = Just $ S.toList disj + wrap conj = error ("simplifyDisjunction: imposible, unexpected conjuction `" ++ show conj ++ "'") + -- Simplification ---------------------------------------------------------------------- -- | @simp eqStore@ simplifies the equation store. -simp :: MonadFresh m => MaudeHandle -> EqStore -> m EqStore -simp hnd eqStore = (`execStateT` (trace (show ("eqStore", eqStore)) eqStore)) $ whileTrue (simp1 hnd) +simp :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> EqStore -> m EqStore +simp hnd isContr eqStore = + (`execStateT` (trace (show ("eqStore", eqStore)) eqStore)) $ whileTrue (simp1 hnd isContr) -- | @simp1@ tries to execute one simplification step -- for the equation store. It returns @True@ if -- the equation store was modified. -simp1 :: MonadFresh m => MaudeHandle -> StateT EqStore m Bool -simp1 hnd = do +simp1 :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> StateT EqStore m Bool +simp1 hnd isContr = do s <- MS.get - b1 <- simpMinimize - b2 <- simpRemoveRenamings - b3 <- simpEmptyDisj - b4 <- foreachDisj hnd simpSingleton - b5 <- foreachDisj hnd simpAbstractSortedVar - b6 <- foreachDisj hnd simpIdentify - b7 <- foreachDisj hnd simpAbstractFun - b8 <- foreachDisj hnd simpAbstractName - s' <- MS.get - (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8], s, s'))) $ return $ (or [b1, b2, b3, b4, b5, b6, b7, b8]) + if eqsIsFalse s + then return False + else do + b1 <- simpMinimize isContr + b2 <- simpRemoveRenamings + b3 <- simpEmptyDisj + b4 <- foreachDisj hnd simpSingleton + b5 <- foreachDisj hnd simpAbstractSortedVar + b6 <- foreachDisj hnd simpIdentify + b7 <- foreachDisj hnd simpAbstractFun + b8 <- foreachDisj hnd simpAbstractName + (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8]))) $ return $ (or [b1, b2, b3, b4, b5, b6, b7, b8]) + -- | Remove variable renamings in fresh substitutions. simpRemoveRenamings :: MonadFresh m => StateT EqStore m Bool simpRemoveRenamings = do conj <- gets (get eqsConj) - let (conj',changed) = - runState (traverse (traverse rmRenamings) conj) False - when changed $ MS.modify (set eqsConj conj') - return changed - where - rmRenamings :: LNSubstVFresh -> State Bool LNSubstVFresh - rmRenamings subst = do - let subst' = removeRenamings subst - when (domVFresh subst /= domVFresh subst') $ put True - return subst' + if F.any (S.foldl' (\b subst -> b || domVFresh subst /= domVFresh (removeRenamings subst)) False) conj + then MS.modify (set eqsConj $ fmap (S.map removeRenamings) conj) >> return True + else return False + -- | If empty disjunction is found, the whole conjunct -- can be simplified to False. simpEmptyDisj :: MonadFresh m => StateT EqStore m Bool @@ -239,45 +254,48 @@ then MS.modify (set eqsConj falseEqConstrConj) >> return True else return False + -- | If there is a singleton disjunction, it can be -- composed with the free substitution. -simpSingleton :: MonadFresh m => Disj LNSubstVFresh - -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh])) -simpSingleton (Disj [subst0]) = do - subst <- freshToFree subst0 - return (Just (Just subst, [])) -simpSingleton _ = return Nothing +simpSingleton :: MonadFresh m + => [LNSubstVFresh] + -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])) +simpSingleton [subst0] = do + subst <- freshToFree subst0 + return (Just (Just subst, [])) +simpSingleton _ = return Nothing -- | If all substitutions @si@ map a variable @v@ to terms with the same -- outermost function symbol @f@, then they all contain the common factor -- @{v |-> f(x1,..,xk)}@ for fresh variables xi and we can replace -- @x |-> ..@ by @{x1 |-> ti1, x2 |-> ti2, ..}@ in all substitutions @si@. -simpAbstractFun :: MonadFresh m => Disj LNSubstVFresh - -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh])) -simpAbstractFun (Disj []) = return Nothing -simpAbstractFun (Disj (subst:others)) = case commonOperators of - [] -> return Nothing +simpAbstractFun :: MonadFresh m + => [LNSubstVFresh] + -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])) +simpAbstractFun [] = return Nothing +simpAbstractFun (subst:others) = case commonOperators of + [] -> return Nothing -- abstract all arguments (v, o, argss@(args:_)):_ | all ((==length args) . length) argss -> do fvars <- mapM (\_ -> freshLVar "x" LSortMsg) args let substs' = zipWith (abstractAll v fvars) (subst:others) argss - fsubst = substFromList [(v, FApp o (map varTerm fvars))] - return $ Just (Just $ fsubst, [Disj substs']) + fsubst = substFromList [(v, fApp o (map varTerm fvars))] + return $ Just (Just fsubst, [S.fromList substs']) -- abstract first two arguments (v, o@(AC _), argss):_ -> do fv1 <- freshLVar "x" LSortMsg fv2 <- freshLVar "x" LSortMsg let substs' = zipWith (abstractTwo o v fv1 fv2) (subst:others) argss - fsubst = substFromList [(v, FApp o (map varTerm [fv1,fv2]))] - return $ Just (Just $ fsubst, [Disj substs']) + fsubst = substFromList [(v, fApp o (map varTerm [fv1,fv2]))] + return $ Just (Just fsubst, [S.fromList substs']) (_, _ ,_):_ -> - error "simpAbstract: impossible, invalid arities or List operator encountered." + error "simpAbstract: impossible, invalid arities or List operator encountered." where commonOperators = do - (v, FApp o args) <- substToListVFresh subst + (v, viewTerm -> FApp o args) <- substToListVFresh subst let images = map (\s -> imageOfVFresh s v) others - argss = [ args' | Just (FApp o' args') <- images, o' == o ] + argss = [ args' | Just (viewTerm -> FApp o' args') <- images, o' == o ] guard (length argss == length others) return (v, o, args:argss) @@ -292,72 +310,73 @@ newMappings [a1,a2] = [(fv1, a1), (fv2, a2)] -- here we always abstract from left to right and do not -- take advantage of the AC property of o - newMappings (a:as) = [(fv1, a), (fv2, FApp o as)] + newMappings (a:as) = [(fv1, a), (fv2, fApp o as)] -- | If all substitutions @si@ map a variable @v@ to the same name @n@, -- then they all contain the common factor -- @{v |-> n}@ and we can remove @{v -> n} from all substitutions @si@ -simpAbstractName :: MonadFresh m => Disj LNSubstVFresh - -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh])) -simpAbstractName (Disj []) = return Nothing -simpAbstractName (Disj (subst:others)) = case commonNames of +simpAbstractName :: MonadFresh m + => [LNSubstVFresh] + -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])) +simpAbstractName [] = return Nothing +simpAbstractName (subst:others) = case commonNames of [] -> return Nothing (v, c):_ -> return $ Just (Just $ substFromList [(v, c)] - , [Disj (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))]) - + , [S.fromList (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))]) where commonNames = do - (v, c@(Lit (Con _))) <- substToListVFresh subst + (v, c@(viewTerm -> Lit (Con _))) <- substToListVFresh subst let images = map (\s -> imageOfVFresh s v) others guard (length images == length [ () | Just c' <- images, c' == c]) return (v, c) + -- | If all substitutions @si@ map a variable @v@ to variables @xi@ of the same -- sort @s@ then they all contain the common factor -- @{v |-> y}@ for a fresh variable of sort @s@ -- and we can replace @{v -> xi}@ by @{y -> xi} in all substitutions @si@ -simpAbstractSortedVar :: MonadFresh m => Disj LNSubstVFresh - -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh])) -simpAbstractSortedVar (Disj []) = return Nothing -simpAbstractSortedVar (Disj (subst:others)) = case commonSortedVar of +simpAbstractSortedVar :: MonadFresh m + => [LNSubstVFresh] + -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])) +simpAbstractSortedVar [] = return Nothing +simpAbstractSortedVar (subst:others) = case commonSortedVar of [] -> return Nothing (v, s, lvs):_ -> do fv <- freshLVar (lvarName v) s return $ Just (Just $ substFromList [(v, varTerm fv)] - , [Disj (zipWith (replaceMapping v fv) lvs (subst:others))]) + , [S.fromList (zipWith (replaceMapping v fv) lvs (subst:others))]) where commonSortedVar = do - (v, (Lit (Var lx))) <- substToListVFresh subst + (v, (viewTerm -> Lit (Var lx))) <- substToListVFresh subst guard (sortCompare (lvarSort v) (lvarSort lx) == Just GT) let images = map (\s -> imageOfVFresh s v) others -- FIXME: could be generalized to choose topsort s of all images if s < sortOf v -- could also be generalized to terms of a given sort - goodImages = [ ly | Just (Lit (Var ly)) <- images, lvarSort lx == lvarSort ly] + goodImages = [ ly | Just (viewTerm -> Lit (Var ly)) <- images, lvarSort lx == lvarSort ly] guard (length images == length goodImages) return (v, lvarSort lx, (lx:goodImages)) replaceMapping v fv lv sigma = substFromListVFresh $ (filter ((/=v) . fst) $ substToListVFresh sigma) ++ [(fv, varTerm lv)] - - -- | If all substitutions @si@ map two variables @x@ and @y@ to identical terms @ti@, -- then they all contain the common factor @{x |-> y} for a fresh variable @z@ -- and we can remove @{x |-> ti}@ from all @si@. -simpIdentify :: MonadFresh m => Disj (LNSubstVFresh) - -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh])) -simpIdentify (Disj []) = return Nothing -simpIdentify (Disj (subst:others)) = case equalImgPairs of +simpIdentify :: MonadFresh m + => [LNSubstVFresh] + -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])) +simpIdentify [] = return Nothing +simpIdentify (subst:others) = case equalImgPairs of [] -> return Nothing ((v,v'):_) -> do - let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of - Just GT -> (v', v) - Just _ -> (v, v') - Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: " - ++ show v ++" and "++ show v' - return $ Just (Just (substFromList [(vremove, varTerm vkeep)]), - [Disj (map (removeMappings [vkeep]) (subst:others))]) + let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of + Just GT -> (v', v) + Just _ -> (v, v') + Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: " + ++ show v ++" and "++ show v' + return $ Just (Just (substFromList [(vremove, varTerm vkeep)]), + [S.fromList (map (removeMappings [vkeep]) (subst:others))]) where equalImgPairs = do (v,t) <- substToListVFresh subst @@ -368,71 +387,38 @@ imageOfVFresh s v == imageOfVFresh s v' && isJust (imageOfVFresh s v) removeMappings vs s = restrictVFresh (domVFresh s \\ vs) s --- | Traverse disjunctions without msgBefore fact in conjunction and --- execute @f@ until it returns @Just (mfreeSubst, disjs)@. + +-- | Simplify by removing substitutions that occur twice in a disjunct. +-- We could generalize this function by using AC-equality or subsumption. +simpMinimize :: MonadFresh m => (LNSubstVFresh -> Bool) -> StateT EqStore m Bool +simpMinimize isContr = do + conj <- MS.gets (get eqsConj) + if F.any (S.foldr (\subst b -> subst == emptySubstVFresh || isContr subst || b) False) conj + then MS.modify (set eqsConj (fmap minimize conj)) >> return True + else return False + where minimize substs + | emptySubstVFresh `S.member` substs = S.singleton emptySubstVFresh + | otherwise = S.filter (not . isContr) substs + + +-- | Traverse disjunctions and execute @f@ until it returns +-- @Just (mfreeSubst, disjs)@. -- Then the @disjs@ is inserted at the current position, if @mfreeSubst@ is -- @Just freesubst@, then it is applied to the equation store. @True@ is -- returned if any modifications took place. foreachDisj :: MonadFresh m => MaudeHandle - -> (Disj (LNSubstVFresh) -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh]))) + -> ([LNSubstVFresh] -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))) -> StateT EqStore m Bool -foreachDisj hnd f = do - conj <- gets (get eqsConj) - go [] (getConj conj) +foreachDisj hnd f = + go [] =<< gets (getConj . get eqsConj) where go _ [] = return False go lefts (d:rights) = do - b <- lift $ f d + b <- lift $ f (S.toList d) case b of Nothing -> go (d:lefts) rights Just (msubst, disjs) -> do - MS.modify (set eqsConj (Conj (reverse lefts ++ disjs ++ rights))) - maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst - return True - - --- Renaming and subsumption ----------------------------------------------------------------------- - --- | Simplify by removing substitutions that occur twice in a disjunct. --- We could generalize this function by using AC-equality or subsumption. -simpMinimize :: MonadFresh m => StateT EqStore m Bool -simpMinimize = do - eqs <- MS.get - let eqs' = modify eqsConj (fmap (Disj . sortednub . getDisj)) eqs - MS.put eqs' - return (eqs /= eqs') - -{- - - -t2 = simpAbstract (Disj (map substFromListVFresh [s1,s2])) `evalFresh` nothingUsed - where s1 = [(lx1,pair(y1,y2))] - s2 = [(lx1,pair(inv(y1),inv(y2)))] - - -t3 = simpAbstract (Disj (map substFromListVFresh [s1,s2,s3])) `evalFresh` nothingUsed - where s1 = [(lx1, mult [y1,y2] )] - s2 = [(lx1, mult [inv(y1), inv(y2), inv(y3)])] - s3 = [(lx1, mult[y5, y6, y7, y8])] - - -t4 = simpIdentify (Disj (map substFromListVFresh [s1,s2])) `evalFresh` nothingUsed - where s1 = [(lx1, mult [y1,y2,y3] ), (lx2, mult [y1,y2,y3] )] - s2 = [(lx1, mult [inv(y1), inv(y2), inv(y3)]), (lx2, mult [inv(y1), inv(y2), inv(y3)])] - --} - -{- -t5 = simpAbstractFun (Disj (map substFromListVFresh [s1,s2,s3])) `evalFresh` nothingUsed - where s1 = [(lx1, mult [y1,y2] )] - s2 = [(lx1, x3)] - s3 = [(lx1, mult[y5, y6, y7, y8])] - -t6 = simpIdentify (Disj (map substFromListVFresh [s1,s2,s3])) `evalFresh` nothingUsed - where s1 = [(lx1, mult [y1,y2,y3] ), (lx2, mult [y1,y2,y3] )] - s2 = [(lx1, mult [inv(y1), inv(y2), inv(y3)]), (lx2, mult [inv(y1), inv(y2), inv(y3)])] - s3 = [(lx1, y1), (lx2, y2)] - --} + MS.modify (set eqsConj (Conj (reverse lefts ++ disjs ++ rights))) + maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst + return True diff --git a/src/Theory/Proof/Guarded.hs b/src/Theory/Proof/Guarded.hs --- a/src/Theory/Proof/Guarded.hs +++ b/src/Theory/Proof/Guarded.hs @@ -77,6 +77,7 @@ import Control.Monad.Fresh hiding ( mapM ) import Control.Arrow + ------------------------------------------------------------------------------ -- Types ------------------------------------------------------------------------------ @@ -127,12 +128,12 @@ go (GGuarded qua ss as gf) = fGuarded qua ss as (go gf) -- | Fold a guarded formula with scope info. --- The Int argument denotes the number of +-- The Integer argument denotes the number of -- quantifiers that have been encountered so far. -foldGuardedScope :: (Int -> Atom (VTerm c (BVar v)) -> b) +foldGuardedScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Disj b -> b) -> (Conj b -> b) - -> (Quantifier -> [s] -> Int -> [Atom (VTerm c (BVar v))] -> b -> b) + -> (Quantifier -> [s] -> Integer -> [Atom (VTerm c (BVar v))] -> b -> b) -> Guarded s c v -> b foldGuardedScope fAto fDisj fConj fGuarded = @@ -144,13 +145,13 @@ go !i (GGuarded qua ss as gf) = fGuarded qua ss i' as (go i' gf) where - i' = i + length ss + i' = i + fromIntegral (length ss) -- | Map a guarded formula with scope info. --- The Int argument denotes the number of +-- The Integer argument denotes the number of -- quantifiers that have been encountered so far. -mapGuardedAtoms :: (Int -> Atom (VTerm c (BVar v)) +mapGuardedAtoms :: (Integer -> Atom (VTerm c (BVar v)) -> Atom (VTerm d (BVar w))) -> Guarded s c v -> Guarded s d w @@ -162,9 +163,11 @@ -- Instances ------------------------------------------------------------------------------ +{- instance Functor (Guarded s c) where - fmap f = foldGuarded (GAto . fmap (fmap (fmap (fmap f)))) GDisj GConj - (\qua ss as gf -> GGuarded qua ss (map (fmap (fmap (fmap (fmap f)))) as) gf) + fmap f = foldGuarded (GAto . fmap (fmapTerm (fmap (fmap f)))) GDisj GConj + (\qua ss as gf -> GGuarded qua ss (map (fmap (fmapTerm (fmap (fmap f)))) as) gf) +-} instance Foldable (Guarded s c) where foldMap f = foldGuarded (foldMap (foldMap (foldMap (foldMap f)))) @@ -172,16 +175,16 @@ (mconcat . getConj) (\_qua _ss as b -> foldMap (foldMap (foldMap (foldMap (foldMap f)))) as `mappend` b) - -instance Traversable (Guarded s c) where - traverse f = foldGuarded (liftA GAto . traverse (traverse (traverse (traverse f)))) - (liftA GDisj . sequenceA) - (liftA GConj . sequenceA) - (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverse (traverse (traverse f)))) as <*> gf) +traverseGuarded :: (Applicative f, Ord c, Ord v, Ord a) + => (a -> f v) -> Guarded s c a -> f (Guarded s c v) +traverseGuarded f = foldGuarded (liftA GAto . traverse (traverseTerm (traverse (traverse f)))) + (liftA GDisj . sequenceA) + (liftA GConj . sequenceA) + (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverseTerm (traverse (traverse f)))) as <*> gf) -instance HasFrees (Guarded (String, LSort) c LVar) where - foldFrees f = foldMap (foldFrees f) - mapFrees f = traverse (mapFrees f) +instance Ord c => HasFrees (Guarded (String, LSort) c LVar) where + foldFrees f = foldMap (foldFrees f) + mapFrees f = traverseGuarded (mapFrees f) -- FIXME: remove name hints for variables for saturation? @@ -193,8 +196,8 @@ -- | @substBoundAtom s a@ substitutes each occurence of a bound variables @i@ -- in @dom(s)@ with the corresponding free variable @x=s(i)@ in the atom @a@. -substBoundAtom :: [(Int,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar)) -substBoundAtom s = fmap (fmap (fmap subst)) +substBoundAtom :: Ord c => [(Integer,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar)) +substBoundAtom s = fmap (fmapTerm (fmap subst)) where subst bv@(Bound i') = case lookup i' s of Just x -> Free x Nothing -> bv @@ -203,15 +206,16 @@ -- | @substBound s gf@ substitutes each occurence of a bound -- variable @i@ in @dom(s)@ with the corresponding free variable -- @s(i)=x@ in all atoms in @gf@. -substBound :: [(Int,LVar)] -> LGuarded c -> LGuarded c +substBound :: Ord c => [(Integer,LVar)] -> LGuarded c -> LGuarded c substBound s = mapGuardedAtoms (\j a -> substBoundAtom [(i+j,v) | (i,v) <- s] a) -- | @substFreeAtom s a@ substitutes each occurence of a free variables @v@ -- in @dom(s)@ with the bound variables @i=s(v)@ in the atom @a@. -substFreeAtom :: [(LVar,Int)] +substFreeAtom :: Ord c + => [(LVar,Integer)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar)) -substFreeAtom s = fmap (fmap (fmap subst)) +substFreeAtom s = fmap (fmapTerm (fmap subst)) where subst fv@(Free x) = case lookup x s of Just i -> Bound i Nothing -> fv @@ -220,14 +224,14 @@ -- | @substFreeAtom s gf@ substitutes each occurence of a free variables -- @v in dom(s)@ with the correpsonding bound variables @i=s(v)@ -- in all atoms in @gf@. -substFree :: [(LVar,Int)] -> LGuarded c -> LGuarded c +substFree :: Ord c => [(LVar,Integer)] -> LGuarded c -> LGuarded c substFree s = mapGuardedAtoms (\j a -> substFreeAtom [(v,i+j) | (v,i) <- s] a) -- | Assuming that there are no more bound variables left in an atom of a -- formula, convert it to an atom with free variables only. -bvarToLVar :: Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar) +bvarToLVar :: Ord c => Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar) bvarToLVar = - fmap (fmap (fmap (foldBVar boundError id))) + fmap (fmapTerm (fmap (foldBVar boundError id))) where boundError v = error $ "bvarToLVar: left-over bound variable '" ++ show v ++ "'" @@ -241,7 +245,7 @@ -- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is the -- succedent. In both antecedent and succedent, the bound variables are -- replaced by @vs@. -openGuarded :: (MonadFresh m) +openGuarded :: (Ord c, MonadFresh m) => LGuarded c -> m (Maybe (Quantifier, [LVar], [Atom (VTerm c LVar)], LGuarded c)) openGuarded (GGuarded qua vs as gf) = do xs <- mapM (\(n,s) -> freshLVar n s) vs @@ -253,10 +257,10 @@ openGuarded _ = return Nothing -- | @closeGuarded vs ats gf@ is a smart constructor for @GGuarded@. -closeGuarded :: Quantifier -> [LVar] -> [Atom (VTerm c LVar)] +closeGuarded :: Ord c => Quantifier -> [LVar] -> [Atom (VTerm c LVar)] -> LGuarded c -> LGuarded c closeGuarded qua vs as gf = GGuarded qua vs' as' gf' - where as' = map (substFreeAtom s . fmap (fmap (fmap Free))) as + where as' = map (substFreeAtom s . fmap (fmapTerm (fmap Free))) as gf' = substFree s gf s = zip (reverse vs) [0..] vs' = map (lvarName &&& lvarSort) vs @@ -266,7 +270,7 @@ -- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is -- the succedent. In both antecedent and succedent, the bound variables are -- replaced by @vs@. -openAllGuarded :: (MonadFresh m) +openAllGuarded :: (Ord c, MonadFresh m) => LGuarded c -> m (Maybe ([LVar],[Atom (VTerm c LVar)], LGuarded c)) openAllGuarded = (fmap adapt) . openGuarded where @@ -277,7 +281,7 @@ -- existentially quantified trace formula and @Nothing@ otherwise. In the -- first case, @vs@ is a list of fresh variables and @gf'@ is the body of @gf@ -- with the bound variable replaced by @v@. -openExGuarded :: (MonadFresh m, Eq c) +openExGuarded :: (MonadFresh m, Eq c, Ord c) => LGuarded c -> m (Maybe ([LVar], LGuarded c)) openExGuarded (GGuarded Ex ss as gf0) = do xs <- mapM (uncurry freshLVar) ss @@ -545,7 +549,7 @@ pp gf0@(GGuarded _ _ _ _) = do Just (qua, vs, atoms, gf) <- openGuarded gf0 - dante <- pp (GConj (Conj (map (GAto . fmap (fmap (fmap Free))) atoms))) + dante <- pp (GConj (Conj (map (GAto . fmap (fmapTerm (fmap Free))) atoms))) dsucc <- pp gf return $ sep [ operator_ (show qua) <-> ppVars vs <> operator_ "." , nest 1 dante diff --git a/src/Theory/Proof/Sequent.hs b/src/Theory/Proof/Sequent.hs --- a/src/Theory/Proof/Sequent.hs +++ b/src/Theory/Proof/Sequent.hs @@ -63,7 +63,7 @@ import Control.Monad.Bind import Control.Monad.State (StateT, runStateT, execStateT, gets, put) -import Text.Isar +import Text.PrettyPrint.Class import Extension.Prelude import Extension.Data.Label @@ -75,6 +75,8 @@ import Theory.Proof.Types import Theory.Proof.EquationStore +import Term.Rewriting.Norm (nf', maybeNotNfSubterms) + ------------------------------------------------------------------------------ -- Sequents ------------------------------------------------------------------------------ @@ -84,26 +86,45 @@ -- | Returns the sequent that has to be proven to show that -- given formula holds in the context of the given theory. -sequentFromFormula :: CaseDistKind -> LNFormula -> Sequent -sequentFromFormula kind f = +sequentFromFormula :: CaseDistKind -> SequentTraceQuantifier -> LNFormula -> Sequent +sequentFromFormula kind traceQuantifier f = set sFormulas (S.singleton gf) (emptySequent kind) where - gf = either error id (fromFormulaNegate f) + adapt = case traceQuantifier of + ExistsSomeTrace -> negateGuarded + ExistsNoTrace -> id + gf = either error id (adapt <$> fromFormulaNegate f) ------------------------------------------------------------------------------ -- Graph reasoning ------------------------------------------------------------------------------ --- | True iff there are terms in the sequent that are not in normal form wrt. +-- | True iff there are terms in the node constraints that are not in normal form wrt. -- to 'Term.Rewriting.Norm.norm' (DH/AC). --- --- FIXME: Might also want to check clauses, equation store, and other --- components of sequent. hasNonNormalTerms :: SignatureWithMaude -> Sequent -> Bool hasNonNormalTerms sig se = - any (not . (`runReader` (get sigmMaudeHandle sig)) . nfRule) . M.elems . get sNodes $ se + any (not . (`runReader` hnd) . nf') (maybeNonNormalTerms hnd se) + where hnd = get sigmMaudeHandle sig +-- | Returns all (sub)terms of node constraints that may be not in normal form. +maybeNonNormalTerms :: MaudeHandle -> Sequent -> [LNTerm] +maybeNonNormalTerms hnd se = + sortednub . concatMap getTerms . M.elems . get sNodes $ se + where getTerms (Rule _ ps cs as) = do + f <- ps++cs++as + t <- factTerms f + maybeNotNfSubterms (mhMaudeSig hnd) t + +substCreatesNonNormalTerms :: MaudeHandle -> Sequent -> LNSubstVFresh -> Bool +substCreatesNonNormalTerms hnd se = + \subst -> any (not . nfApply subst) terms + where terms = maybeNonNormalTerms hnd se + nfApply subst0 t = t == t' || nf' t' `runReader` hnd + where tvars = freesList t + subst = restrictVFresh tvars subst0 + t' = apply (freshToFreeAvoidingFast subst tvars) t + -- | True if there is no @EXP-down@ rule that should be replaced by an -- @EXP-up@ rule. hasForbiddenExp :: Sequent -> Bool @@ -122,16 +143,16 @@ isForbiddenExp ru = maybe False id $ do [_,p2] <- return $ get rPrems ru [conc] <- return $ get rConcs ru - (UpK, _, b) <- kFactView p2 - (DnK, Just IsExp, FApp (NonAC ("exp",2)) [g,c]) <- kFactView conc + (UpK, _, b) <- kFactView p2 + (DnK, Just CannotExp, viewTerm2 -> FExp g c) <- kFactView conc -- g should be public and the required inputs for c already required by b guard (sortOfTerm g == LSortPub && (input c \\ input b == [])) return True where - sortOfTerm (Lit (Var lv)) = lvarSort lv - sortOfTerm (Lit (Con n)) = sortOfName n - sortOfTerm _ = LSortMsg + sortOfTerm (viewTerm -> Lit (Var lv)) = lvarSort lv + sortOfTerm (viewTerm -> Lit (Con n)) = sortOfName n + sortOfTerm _ = LSortMsg -- | Compute all contradictions to unique fact instances. @@ -144,7 +165,7 @@ nonUniqueFactInstances :: SignatureWithMaude -> Sequent -> [(NodeId, NodeId, NodeId)] nonUniqueFactInstances sig se = do - Edge c@(NodeConc (i, _)) (NodePrem (k, _)) <- S.toList $ get sEdges se + Edge c@(i, _) (k, _) <- S.toList $ get sEdges se let tag = factTag (nodeConcFact c se) guard (tag `S.member` get sigmUniqueInsts sig) j <- S.toList $ D.reachableSet [i] less @@ -219,7 +240,7 @@ -- | @proveLinearConc se (v,i)@ tries to prove that the @i@-th conclusion of node -- @v@ is a linear fact. proveLinearConc :: Sequent -> NodeConc -> Bool -proveLinearConc se (NodeConc (v,i)) = +proveLinearConc se (v,i) = maybe False (isLinearFact . (get (rConc i))) $ M.lookup v $ get sNodes se -- | Create a node labelled with a fresh instance of one of the rules and solve @@ -229,17 +250,17 @@ ruleNode :: NodeId -> [RuleAC] -> SeProof RuleACInst ruleNode i rules = do (ru, mrconstrs) <- importRule =<< disjunctionOfList rules - solveRuleConstraints mrconstrs i + solveRuleConstraints mrconstrs modM sNodes (M.insert i ru) let inFacts = do - (v, Fact InFact [m]) <- zip [0..] $ get rPrems ru + (v, Fact InFact [m]) <- enumPrems ru return $ do j <- freshLVar "vf" LSortNode ruKnows <- mkISendRuleAC m modM sNodes (M.insert j ruKnows) - modM sEdges (S.insert $ Edge (NodeConc (j,0)) (NodePrem (i,v))) + modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i, v)) let freshFacts = do - (v, Fact FreshFact [m]) <- zip [0..] $ get rPrems ru + (v, Fact FreshFact [m]) <- enumPrems ru return $ do j <- freshLVar "vf" LSortNode modM sNodes (M.insert j (mkFreshRuleAC m)) @@ -247,7 +268,7 @@ -- 'm' must be of sort fresh n <- varTerm <$> freshLVar "n" LSortFresh solveTermEqs SplitNow [Equal m n] - modM sEdges (S.insert $ Edge (NodeConc (j,0)) (NodePrem (i,v))) + modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i,v)) -- solve all Fr and In premises sequence_ inFacts sequence_ freshFacts @@ -255,9 +276,11 @@ where mkISendRuleAC m = do faPrem <- kuFact Nothing m - return $ Rule (ProtoInfo ISendRule) [faPrem] [inFact m] [kLogFact m] + return $ Rule (IntrInfo (ISendRule)) + [faPrem] [inFact m] [kLogFact m] - mkFreshRuleAC m = Rule (ProtoInfo FreshRule) [] [freshFact m] [] + mkFreshRuleAC m = Rule (ProtoInfo (ProtoRuleACInstInfo FreshRule [])) + [] [freshFact m] [] -- | Create a fresh node labelled with a fresh instance of one of the rules -- and solve it's 'Fr' and 'In' facts immediatly. @@ -284,8 +307,8 @@ -> SeProof (RuleACInst, NodeConc, LNFact) freshRuleConc rules = do (i, ru) <- freshRuleNode rules - (v, fa) <- disjunctionOfList $ zip [0..] $ get rConcs ru - return (ru, NodeConc (i,v), fa) + (v, fa) <- disjunctionOfList $ enumConcs ru + return (ru, (i, v), fa) -- | Insert the edges and ensure the equality between the facts -- at either end of the edge. @@ -382,10 +405,10 @@ nodes <- M.toList <$> getM sNodes let (down, up) = partitionEithers $ do (i, ru) <- nodes - (v, fa) <- zip [0..] $ get rConcs ru + (v, fa) <- enumConcs ru (d, _, m) <- maybe mzero return $ kFactView fa let tag = case d of UpK -> Right; DnK -> Left - return $ tag (m, (d, fa, NodeConc (i, v))) + return $ tag (m, (d, fa, (i, v))) -- retain the up-entry if there are duplicates derived = M.fromList $ down ++ up @@ -395,7 +418,7 @@ trySolveGoal derived (PremUpKG p m) = trySolveMessage derived m (\c _ -> modM sMsgEdges (S.insert (MsgEdge c p))) - trySolveGoal derived (PremiseG p faPrem) = case kFactView faPrem of + trySolveGoal derived (PremiseG p faPrem _mayLoop) = case kFactView faPrem of Just (UpK, _, m) -> trySolveMessage derived m -- For premise goals we have 'inp m == [m]'. We must insert a -- direct edge and ensure the equality wrt. an additional coerce @@ -410,8 +433,8 @@ Just (UpK, faConc, c) -> solveWith c faConc >> return True Just (DnK, faConc, c) -> do (j, (faPrem', faConc')) <- freshCoerceRuleNode - insertEdges [ (c, faConc , faPrem', NodePrem (j,0)) ] - _ <- solveWith (NodeConc (j,0)) faConc' + insertEdges [ (c, faConc , faPrem', (j, PremIdx 0)) ] + _ <- solveWith (j, ConcIdx 0) faConc' return True Nothing -> return False @@ -470,7 +493,7 @@ exploitFreshUnique = do -- gather fresh rule nodes and merge nodes with identical conclusions updates <- gets ( map merge - . groupSortOn (get (rConc 0) . snd) + . groupSortOn (get (rConc (ConcIdx 0)) . snd) . filter (isFreshRule . snd) . M.toList . get sNodes @@ -495,27 +518,25 @@ exploitEdgeProps :: SeProof Bool -- True, if a simplification step happened. exploitEdgeProps = do se <- gets id - let edges = [ (getNodeConc src, getNodePrem prem) - | Edge src prem <- S.toList (get sEdges se) ] - rawEqs = mergeEqs fst snd edges ++ - mergeEqs snd fst (filter (proveLinearConc se . NodeConc . fst) edges) - -- check if there are changes to be applied - if all null rawEqs - then do return False - else do - let eqs = concat rawEqs - -- all indices of merged premises and conclusions must be equal - contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs]) - -- nodes must be equal - solveNodeIdEqs $ map (fmap fst) eqs - return True + let edges = S.toList (get sEdges se) + (||) <$> mergeNodes eSrc eTgt edges + <*> mergeNodes eTgt eSrc (filter (proveLinearConc se . eSrc) edges) where - mergeEqs :: Ord c => (a -> b) -> (a -> c) -> [a] -> [[Equal b]] - mergeEqs what on = map (merge what) . groupSortOn on + -- merge the nodes on the 'mergeEnd' for edges that are equal on the + -- 'compareEnd' + mergeNodes mergeEnd compareEnd edges + | null eqs = return False + | otherwise = do + -- all indices of merged premises and conclusions must be equal + contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs]) + -- nodes must be equal + solveNodeIdEqs $ map (fmap fst) eqs + return True + where + eqs = concatMap (merge mergeEnd) $ groupSortOn compareEnd edges - merge :: (a -> b) -> [a] -> [Equal b] - merge _ [] = error "exploitEdgeProps: impossible" - merge proj (keep:remove) = map (Equal (proj keep) . proj) remove + merge _ [] = error "exploitEdgeProps: impossible" + merge proj (keep:remove) = map (Equal (proj keep) . proj) remove -- | Merge nodes with equal non-pair msg conclusions. @@ -593,8 +614,8 @@ else modM sAtoms $ S.insert $ bvarToLVar $ Less j0 i0 Nothing -> [] where - nodeFromTerm (Lit (Var (Free v))) | lvarSort v == LSortNode = v - nodeFromTerm t = error $ + nodeFromTerm (viewTerm -> Lit (Var (Free v))) | lvarSort v == LSortNode = v + nodeFromTerm t = error $ "expected free node variable, but got '" ++ show t ++ "'" @@ -636,8 +657,8 @@ mkEq i j = Equal (varTerm i) (varTerm j) mkOrdDisj i0 j0 = gdisj $ [GAto (EqE i j), GAto (Less i j)] where - i = Lit $ Var $ Free i0 - j = Lit $ Var $ Free j0 + i = lit $ Var $ Free i0 + j = lit $ Var $ Free j0 -- | @setNodes nodes@ normalizes the @nodes@ such that node ids are unique and -- then updates the @sNodes@ field of the proof state to the corresponding map. @@ -737,7 +758,8 @@ solveTermEqs :: SplitStrategy -> [Equal LNTerm] -> SeProof () solveTermEqs splitStrat eqs = do hnd <- getMaudeHandle - setM sEqStore =<< simp hnd + se <- gets id + setM sEqStore =<< simp hnd (substCreatesNonNormalTerms hnd se) =<< disjunctionOfList =<< addEqs splitStrat hnd eqs =<< getM sEqStore @@ -775,14 +797,15 @@ -- | Solve the constraints associated with a rule with the given vertex. -solveRuleConstraints :: Maybe RuleACConstrs -> NodeId -> SeProof () -solveRuleConstraints (Just eqConstr) _v = do +solveRuleConstraints :: Maybe RuleACConstrs -> SeProof () +solveRuleConstraints (Just eqConstr) = do hnd <- getMaudeHandle setM sEqStore - =<< (simp hnd . addRuleVariants eqConstr) + -- do not use expensive substCreatesNonNormalTerms here + =<< (simp hnd (const False) . addRuleVariants eqConstr) =<< getM sEqStore noContradictoryEqStore -solveRuleConstraints Nothing _ = return () +solveRuleConstraints Nothing = return () ------------------------------------------------------------------------------ -- Extracting and solving goals @@ -796,14 +819,15 @@ openPremiseGoals :: Sequent -> [(Usefulness, Goal)] openPremiseGoals se = do (i, ru) <- oneOfMap $ get sNodes se - (u, fa) <- zip [0..] $ get rPrems ru - let p = NodePrem (i, u) + (u, fa) <- enumPrems ru + let p = (i, u) + breakers = ruleInfo (get praciLoopBreakers) (const []) $ get rInfo ru case fa of -- up-K facts (kFactView -> Just (UpK, _, m)) -> case input m of [m'] | m == m' -> do guard (not (trivial m') && (p, m') `S.notMember` coveredMsgPrems) - return $ markUseless m' i $ PremiseG p fa + return $ markUseless m' i $ PremiseG p fa True m's -> do m' <- sortednub m's guard (not (trivial m') && (p, m') `S.notMember` coveredMsgPrems) @@ -815,7 +839,8 @@ | otherwise -> return . (Useful,) $ PremDnKG p -- all other facts _ | p `S.member` coveredPrems -> mzero - | otherwise -> return . (Useful,) $ PremiseG p fa + | u `elem` breakers -> return . (Useless,) $ PremiseG p fa True + | otherwise -> return . (Useful,) $ PremiseG p fa False where coveredPrems = S.fromList $ eTgt <$> S.toList (get sEdges se) <|> cTgt <$> S.toList (get sChains se) @@ -831,7 +856,7 @@ existingDeps = sRawLessRel se -- We use the following heuristic for marking KU-goals as useful (worth - -- solving now) or useless (to be delayed until no more useful goal + -- solving now) or useless (to be delayed until no more useful goals -- remain). We ignore all goals that do not contain a fresh variable -- or where there exists a node, not after the premise or the last node, -- providing an Out or KD conclusion that provides the message we are @@ -847,7 +872,7 @@ toplevelTerms t@(destPair -> Just (t1, t2)) = t : toplevelTerms t1 ++ toplevelTerms t2 - toplevelTerms t@(destInv -> Just t1) = t : toplevelTerms t1 + toplevelTerms t@(destInverse -> Just t1) = t : toplevelTerms t1 toplevelTerms t = [t] deducible = or $ do @@ -879,31 +904,71 @@ openSplitGoals se = SplitG <$> eqSplits (get sEqStore se) -- | All open action goals. +-- +-- FIXME: Only `Ded` goals that are guaranteed to be a non-pair, +-- non-inversion, and non-product are considered open. This is wrong with +-- respect to our definition of a solved form of the constraint system. openActionGoals :: Sequent -> [Goal] -openActionGoals se = uncurry ActionG <$> sActionAtoms se +openActionGoals se = do + (i, fa) <- sActionAtoms se + case dedFactView fa of + Just m | isPair m || isMsgVar m || isProduct m || isInverse m -> mzero + _ -> return $ ActionG i fa -- | All open goals (non-deterministic choices of possible proof steps) in the -- sequent. openGoals :: Sequent -> [Goal] -openGoals se = delayUseless $ concat $ +openGoals se = delayUseless $ sortDecisionTree solveFirst $ concat $ [ (Useful,) <$> openActionGoals se , (Useful,) <$> openDisjunctionGoals se , (Useful,) <$> openChainGoals se - , preferProtoFactGoals $ openPremiseGoals se + , openPremiseGoals se -- SM: Commented out as automatic saturation works again. -- , (Useful,) <$> openImplicationGoals se , (Useful,) <$> openSplitGoals se ] where - isProtoFactGoal (_, PremiseG _ _) = True - isProtoFactGoal _ = False - preferProtoFactGoals goals = - uncurry (++) $ partition isProtoFactGoal goals + solveFirst = map (. snd) + [ isDisjGoal, isProtoFactGoal + , isActionGoal + , isChainGoal, isFreshKnowsGoal + , isSplitGoalSmall, isDoubleExpGoal ] + isProtoFactGoal (PremiseG _ (Fact KUFact _) _) = False + isProtoFactGoal (PremiseG _ _ _) = True + isProtoFactGoal _ = False + + msgPremise (PremiseG _ (Fact KUFact [_, m]) _) = Just m + msgPremise (PremUpKG _ m) = Just m + msgPremise _ = Nothing + + isFreshKnowsGoal goal = case msgPremise goal of + Just (viewTerm -> Lit (Var lv)) | lvarSort lv == LSortFresh -> True + _ -> False + + isDoubleExpGoal goal = case msgPremise goal of + Just (viewTerm2 -> FExp _ (viewTerm2 -> FMult _)) -> True + _ -> False + + isSplitGoalSmall (SplitG sid) = splitCasenum (get sEqStore se) sid < 3 + isSplitGoalSmall _ = False + delayUseless = map snd . sortOn fst +-- | @sortDecisionTree xs ps@ returns a reordering of @xs@ +-- such that the sublist satisfying @ps!!0@ occurs first, +-- then the sublist satisfying @ps!!1@, and so on. +sortDecisionTree :: [a -> Bool] -> [a] -> [a] +sortDecisionTree [] xs = xs +sortDecisionTree (p:ps) xs = sat ++ sortDecisionTree ps nonsat + where (sat, nonsat) = partition p xs + -- | Solve an action goal. +-- +-- PRE: If the action is a 'Ded' fact, then its argument must not be +-- instantiatable to a pair, inversion, or a product. +-- solveAction :: [RuleAC] -- ^ All rules labelled with an action -> (LVar, LNFact) -- ^ The action we are looking for. -> SeProof String -- ^ Sensible case name. @@ -911,10 +976,15 @@ modM sAtoms (S.delete (Action (varTerm i) fa)) mayRu <- M.lookup i <$> getM sNodes showRuleCaseName <$> case mayRu of - Nothing -> do ru <- ruleNode i rules - act <- disjunctionOfList $ get rActs ru - solveFactEqs SplitNow [Equal fa act] - return ru + Nothing -> do -- case dedFactView fa of + -- Just m -> do -- 'Ded' facts are dealt with specially. + -- solvePremUpK + -- Nothing -> do + ru <- ruleNode i rules + act <- disjunctionOfList $ get rActs ru + solveFactEqs SplitNow [Equal fa act] + return ru + Just ru -> do unless (fa `elem` get rActs ru) $ do act <- disjunctionOfList $ get rActs ru solveFactEqs SplitNow [Equal fa act] @@ -955,11 +1025,11 @@ solvePremDnK rules p = do iLearn <- freshLVar "vl" LSortNode mLearn <- varTerm <$> freshLVar "t" LSortMsg - concLearn <- kdFact (Just IsNoExp) mLearn + concLearn <- kdFact (Just CanExp) mLearn let premLearn = outFact mLearn - ruLearn = Rule (ProtoInfo IRecvRule) [premLearn] [concLearn] [] - cLearn = NodeConc (iLearn, 0) - pLearn = NodePrem (iLearn, 0) + ruLearn = Rule (IntrInfo IRecvRule) [premLearn] [concLearn] [] + cLearn = (iLearn, ConcIdx 0) + pLearn = (iLearn, PremIdx 0) modM sNodes (M.insert iLearn ruLearn) modM sChains (S.insert (Chain cLearn p)) solvePremise rules pLearn premLearn @@ -978,16 +1048,16 @@ let m = case kFactView faConc of Just (DnK, _, m') -> m' _ -> error $ "solveChain: impossible" - caseName (FApp o _) = show o - caseName t = show t + caseName (viewTerm -> FApp o _) = show o + caseName t = show t return $ caseName m `disjunction` do -- extend it with one step (i, ru) <- freshRuleNode rules - (v, faPrem) <- disjunctionOfList $ zip [0..] $ get rPrems ru + (v, faPrem) <- disjunctionOfList $ enumPrems ru solveFactEqs SplitNow [(Equal faPrem faConc)] - modM sEdges (S.insert (Edge c (NodePrem (i,v)))) - modM sChains (S.insert (Chain (NodeConc (i,0)) p)) + modM sEdges (S.insert (Edge c (i, v))) + modM sChains (S.insert (Chain (i, ConcIdx 0) p)) return $ showRuleCaseName ru ) @@ -998,7 +1068,8 @@ let errMsg = error "solveSplit: split of equations on unconstrained variable!" store <- maybe errMsg disjunctionOfList split hnd <- getMaudeHandle - store' <- simp hnd store + se <- gets id + store' <- simp hnd (substCreatesNonNormalTerms hnd se) store contradictoryIf (eqsIsFalse store') sEqStore =: store' return "split" @@ -1024,7 +1095,7 @@ trace (" solving goal: " ++ render (prettyGoal goal)) $ case goal of ActionG i fa -> solveAction (nonSilentRules rules) (i, fa) - PremiseG p fa -> + PremiseG p fa _mayLoop -> solvePremise (get crProtocol rules ++ get crConstruct rules) p fa PremDnKG p -> solvePremDnK (get crProtocol rules) p PremUpKG p m -> solvePremUpK (get crConstruct rules) p m diff --git a/src/Theory/Proof/Sequent/Dot.hs b/src/Theory/Proof/Sequent/Dot.hs --- a/src/Theory/Proof/Sequent/Dot.hs +++ b/src/Theory/Proof/Sequent/Dot.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, TypeOperators #-} +{-# LANGUAGE TemplateHaskell, ViewPatterns, TypeOperators #-} -- | -- Copyright : (c) 2010, 2011 Simon Meier -- License : GPL v3 (see LICENSE) @@ -11,14 +11,17 @@ dotSequentLoose , dotSequentCompact , compressSequent + , BoringNodeStyle(..) ) where import Safe import Data.Maybe +import Data.Char (isSpace) import Data.List import Data.Monoid (Any(..)) -import qualified Data.Set as S -import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.DAG.Simple as D import Data.Color import Extension.Prelude @@ -29,12 +32,12 @@ import Control.Monad.Reader import qualified Text.Dot as D -import Text.Isar hiding (style) +import Text.PrettyPrint.Class import Theory.Rule import Theory.Proof.Sequent -type NodeColorMap = M.Map (RuleInfo ProtoRuleName IntrRuleACInfo) (HSV Double) +type NodeColorMap = M.Map (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) (HSV Double) type SeDot = ReaderT (Sequent, NodeColorMap) (StateT DotState D.Dot) -- | State to avoid multiple drawing of the same entity. @@ -104,16 +107,16 @@ nodeColor = maybe "white" (rgbToHex . lighter) color dot (label ru) [("fillcolor", nodeColor),("style","filled")] $ \vId -> do premIds <- mapM dotPrem - [ NodePrem (v,i) | (i,_) <- zip [0..] $ get rPrems ru ] - concIds <- mapM (dotConc . NodeConc) - [ (v,i) | (i,_) <- zip [0..] $ get rConcs ru ] + [ (v,i) | (i,_) <- enumPrems ru ] + concIds <- mapM dotConc + [ (v,i) | (i,_) <- enumConcs ru ] sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ] sequence_ [ dotIntraRuleEdge vId concId | concId <- concIds ] where label ru = " : " ++ render nameAndActs where nameAndActs = - ruleInfo prettyProtoRuleName prettyIntrRuleACInfo (get rInfo ru) <-> + ruleInfo (prettyProtoRuleName . get praciName) prettyIntrRuleACInfo (get rInfo ru) <-> brackets (vcat $ punctuate comma $ map prettyLNFact $ get rActs ru) -- | An edge from a rule node to its premises or conclusions. @@ -155,13 +158,13 @@ -- | Premises. dotPrem :: NodePrem -> SeDot D.NodeId -dotPrem prem@(NodePrem (v,i)) = +dotPrem prem@(v, i) = dotOnce dsPrems prem $ dotTrySingleEdge snd prem $ do nodes <- asks (get sNodes . fst) let ppPrem = show prem -- FIXME: Use better pretty printing here (label, moreStyle) = fromMaybe (ppPrem, []) $ do ru <- M.lookup v nodes - fa <- get rPrems ru `atMay` i + fa <- lookupPrem i ru return ( render $ prettyLNFact fa , factNodeStyle fa ) @@ -173,7 +176,7 @@ -- | Conclusions. dotConc :: NodeConc -> SeDot D.NodeId dotConc = - dotNodeWithIndex dsConcs fst rConcs getNodeConc "trapezium" + dotNodeWithIndex dsConcs fst rConcs (id *** getConcIdx) "trapezium" where dotNodeWithIndex stateSel edgeSel ruleSel unwrap shape x0 = dotOnce stateSel x0 $ dotTrySingleEdge edgeSel x0 $ do @@ -204,12 +207,12 @@ return (from, to) sequence_ $ do (v, ru) <- M.toList $ get sNodes se - (i, _) <- zip [0..] $ get rConcs ru - return (dotConc (NodeConc (v, i))) + (i, _) <- enumConcs ru + return (dotConc (v, i)) sequence_ $ do (v, ru) <- M.toList $ get sNodes se - (i, _) <- zip [0..] $ get rPrems ru - return (dotPrem (NodePrem (v,i))) + (i, _) <- enumPrems ru + return (dotPrem (v,i)) mapM_ dotNode $ M.keys $ get sNodes se mapM_ dotEdge $ S.toList $ get sEdges se mapM_ dotChain $ S.toList $ get sChains se @@ -293,46 +296,94 @@ -- Record based dotting ------------------------------------------------------------------------------ +-- | The style for nodes of the intruder. +data BoringNodeStyle = FullBoringNodes | CompactBoringNodes + deriving( Eq, Ord, Show ) + + -- | Dot a node in record based (compact) format. -dotNodeCompact :: NodeId -> SeDot D.NodeId -dotNodeCompact v = dotOnce dsNodes v $ do +dotNodeCompact :: BoringNodeStyle -> NodeId -> SeDot D.NodeId +dotNodeCompact boringStyle v = dotOnce dsNodes v $ do (se, colorMap) <- ask + let hasOutgoingEdge = + or [ v == v' | Edge (v', _) _ <- S.toList $ get sEdges se ] + || or [ v == v' | MsgEdge (v', _) _ <- S.toList $ get sMsgEdges se ] case M.lookup v $ get sNodes se of - Nothing -> liftDot $ D.node $ [("label", show v),("shape","ellipse")] + Nothing -> mkSimpleNode (show v) [] Just ru -> do let color = M.lookup (get rInfo ru) colorMap nodeColor = maybe "white" (rgbToHex . lighter) color attrs = [("fillcolor", nodeColor),("style","filled")] - (_, ids) <- liftDot $ D.record (mkRecord ru) attrs - let prems = [ (NodePrem (v, i), nid) | (Just (Left i), nid) <- ids ] - concs = [ (NodeConc (v, i), nid) | (Just (Right i), nid) <- ids ] + ids <- mkNode ru attrs hasOutgoingEdge + let prems = [ ((v, i), nid) | (Just (Left i), nid) <- ids ] + concs = [ ((v, i), nid) | (Just (Right i), nid) <- ids ] modM dsPrems $ M.union $ M.fromList prems modM dsConcs $ M.union $ M.fromList concs return $ fromJust $ lookup Nothing ids where - mkRecord ru = D.vcat $ map D.hcat $ filter (not . null) - [ [ D.portField (Just (Left i)) (render (prettyLNFact p)) - | (i, p) <- zip [(0::Int)..] $ get rPrems ru ] - , [ D.portField Nothing (show v ++ " : " ++ showRuleCaseName ru ++ acts) ] - , [ D.portField (Just (Right i)) (render (prettyLNFact c)) - | (i, c) <- zip [(0::Int)..] $ get rConcs ru ] - ] + + mkSimpleNode lbl attrs = + liftDot $ D.node $ [("label", lbl),("shape","ellipse")] ++ attrs + + mkNode ru attrs hasOutgoingEdge + -- single node, share node-id for all premises and conclusions + | boringStyle == CompactBoringNodes && + (isIntruderRule ru || isFreshRule ru) = do + let lbl | hasOutgoingEdge = show v ++ " : " ++ showRuleCaseName ru + | otherwise = concatMap snd as + nid <- mkSimpleNode lbl [] + return [ (key, nid) | (key, _) <- ps ++ as ++ cs ] + -- full record syntax + | otherwise = + fmap snd $ liftDot $ (`D.record` attrs) $ + D.vcat $ map D.hcat $ map (map (uncurry D.portField)) $ + filter (not . null) [ps, as, cs] where - acts = (" " ++) $ render $ - brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru - + ps = renderRow [ (Just (Left i), prettyLNFact p) | (i, p) <- enumPrems ru ] + as = renderRow [ (Nothing, ruleLabel ) ] + cs = renderRow [ (Just (Right i), prettyLNFact c) | (i, c) <- enumConcs ru ] + ruleLabel = + prettyNodeId v <-> colon <-> text (showRuleCaseName ru) <> + (brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru) + + renderRow annDocs = + zipWith (\(ann, _) lbl -> (ann, lbl)) annDocs $ + -- magic factor 1.3 compensates for space gained due to + -- non-propertional font + renderBalanced 100 (max 30 . round . (* 1.3)) (map snd annDocs) + + renderBalanced :: Double -- ^ Total available width + -> (Double -> Int) -- ^ Convert available space to actual line-width. + -> [Doc] -- ^ Initial documents + -> [String] -- ^ Rendered documents + renderBalanced _ _ [] = [] + renderBalanced totalWidth conv docs = + zipWith (\w d -> widthRender (conv (ratio * w)) d) usedWidths docs + where + oneLineRender = renderStyle (defaultStyle { mode = OneLineMode }) + widthRender w = scaleIndent . renderStyle (defaultStyle { lineLength = w }) + usedWidths = map (fromIntegral . length . oneLineRender) docs + ratio = totalWidth / sum usedWidths + scaleIndent line = case span isSpace line of + (spaces, rest) -> + -- spaces are not wide-enough by default => scale them up + let n = (1.5::Double) * fromIntegral (length spaces) + in replicate (round n) ' ' ++ rest + + + -- | Dot a sequent in compact form (one record per rule) -dotSequentCompact :: Sequent -> D.Dot () -dotSequentCompact se = +dotSequentCompact :: BoringNodeStyle -> Sequent -> D.Dot () +dotSequentCompact boringStyle se = (`evalStateT` DotState M.empty M.empty M.empty M.empty) $ (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do liftDot $ setDefaultAttributes - mapM_ dotNodeCompact $ M.keys $ get sNodes se - mapM_ dotEdge $ S.toList $ get sEdges se - mapM_ dotChain $ S.toList $ get sChains se - mapM_ dotMsgEdge $ S.toList $ get sMsgEdges se - mapM_ dotLess $ sLessAtoms se + mapM_ (dotNodeCompact boringStyle) $ M.keys $ get sNodes se + mapM_ dotEdge $ S.toList $ get sEdges se + mapM_ dotChain $ S.toList $ get sChains se + mapM_ dotMsgEdge $ S.toList $ get sMsgEdges se + mapM_ dotLess $ sLessAtoms se where missingNode shape label = liftDot $ D.node $ [("label", render label),("shape",shape)] dotPremC prem = dotOnce dsPrems prem $ missingNode "invtrapezium" $ prettyNodePrem prem @@ -340,7 +391,9 @@ dotEdge (Edge src tgt) = do let check p = maybe False p (resolveNodePremFact tgt se) || maybe False p (resolveNodeConcFact src se) - attrs | check isProtoFact = [("style","bold"),("weight","10.0")] + attrs | check isProtoFact = + [("style","bold"),("weight","10.0")] ++ + (guard (check isPersistentFact) >> [("color","gray50")]) | check isKFact = [("color","orangered2")] | otherwise = [("color","gray30")] dotGenEdge attrs src tgt @@ -349,7 +402,7 @@ srcId <- dotConcC src tgtId <- dotPremC tgt liftDot $ D.edge srcId tgtId style - + dotChain (Chain src tgt) = dotGenEdge [("style","dashed"),("color","green")] src tgt @@ -357,47 +410,50 @@ dotGenEdge [("style","dotted"),("color","orange")] src tgt dotLess (src, tgt) = do - srcId <- dotNodeCompact src - tgtId <- dotNodeCompact tgt + srcId <- dotNodeCompact boringStyle src + tgtId <- dotNodeCompact boringStyle tgt liftDot $ D.edge srcId tgtId [("color","black"),("style","dotted"),("constraint","false")] -- setting constraint to false ignores less-edges when ranking nodes. - {- - dotProvides (SeProvides v fa) = do - vId <- dotNodeCompact v - faId <- liftDot $ D.node [("label",label),("shape","trapezium")] - dotNonFixedIntraRuleEdge vId faId - where - label = render $ prettyLNFact fa - dotRequires (SeRequires v _fa) = do - _vId <- dotNodeCompact v - return () - -- FIXME: Reenable - -- premId <- dotPremC (NodePremFact v fa) - -- dotNonFixedIntraRuleEdge premId vId - -} ------------------------------------------------------------------------------ -- Compressed versions of a sequent ------------------------------------------------------------------------------ +-- | Drop 'Less' atoms entailed by the edges of the 'Sequent'. +dropEntailedOrdConstraints :: Sequent -> Sequent +dropEntailedOrdConstraints se = + modify sAtoms (S.filter (not . entailed)) se + where + edges = sRawEdgeRel se + + entailed (Less (viewTerm -> Lit (Var from)) (viewTerm -> Lit (Var to))) = + to `S.member` D.reachableSet [from] edges + entailed _ = False + -- | Unsound compression of the sequent that drops fully connected learns and -- knows nodes. compressSequent :: Sequent -> Sequent -compressSequent se = +compressSequent se0 = foldl' (flip hideTransferNode) se $ [ x | x@(_, ru) <- M.toList $ get sNodes se - , isFreshRule ru || isDestrRule ru || isConstrRule ru || isIRecvRule ru || isISendRule ru ] + , isFreshRule ru || isIntruderRule ru ] + where + se = dropEntailedOrdConstraints se0 -- | @hideTransferNode v se@ hides node @v@ in sequent @se@ if it is a --- transfer node; i.e., a node annotated with a rule with exactly one premise --- and one conclusion with exactly one incoming and one outgoing edge. +-- transfer node; i.e., a node annotated with a rule that is one of the +-- special intruder rules or a rule with with at most one premise and +-- at most one conclusion and both premises and conclusions have incoming +-- respectively outgoing edges. +-- +-- The compression is chosen such that unly uninteresting nodes are that have +-- no open goal are suppressed. hideTransferNode :: (NodeId, RuleACInst) -> Sequent -> Sequent hideTransferNode (v, ru) se = fromMaybe se $ do guard $ - all (\l -> length (get l ru) <= 1) [rPrems, rConcs] - && (null $ get rActs ru) + eligibleRule && (length eIns == length (get rPrems ru)) && (length eOuts == length (get rConcs ru)) && all (\(Edge cIn pOut) -> nodeConcNode cIn /= nodePremNode pOut) eNews @@ -413,6 +469,12 @@ $ modify sNodes (M.delete v) $ se where + eligibleRule = + any ($ ru) [isISendRule, isIRecvRule, isCoerceRule, isFreshRule] || + ( null (get rActs ru) && + all (\l -> length (get l ru) <= 1) [rPrems, rConcs] + ) + selectPart :: (Sequent :-> S.Set a) -> (a -> Bool) -> [a] selectPart l p = filter p $ S.toList $ get l se diff --git a/src/Theory/Proof/SolveGuarded.hs b/src/Theory/Proof/SolveGuarded.hs --- a/src/Theory/Proof/SolveGuarded.hs +++ b/src/Theory/Proof/SolveGuarded.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, StandaloneDeriving, TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + -- spurious warnings for view patterns -- | -- Copyright : (c) 2011, 2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE) @@ -21,8 +24,6 @@ import Theory.Atom import Term.LTerm -import Term.Rewriting.NormAC - import Theory.Proof.Types import Data.Typeable @@ -93,10 +94,10 @@ modM sSolvedFormulas (S.insert fm) case bvarToLVar ato of EqE s t -- only add non-trivial equalities - | not (s ==# t) -> return $ Just $ Equal s t + | not (s == t) -> return $ Just $ Equal s t | otherwise -> return Nothing - EdgeA (Lit (Var i), v) (Lit (Var j), u) -> do - modM sEdges $ S.insert $ Edge (NodeConc (i,v)) (NodePrem (j,u)) + EdgeA (viewTerm -> Lit (Var i), v) (viewTerm -> Lit (Var j), u) -> do + modM sEdges $ S.insert $ Edge (i, v) (j, u) return Nothing EdgeA _ _ -> error $ "saturateGuarded: ill-formed edge atom: " ++ show ato @@ -164,15 +165,15 @@ hapBefore = happensBefore se atomHolds subst ato = case unskolemizeTerm . applySkTerm subst <$> ato of - Action _ _ -> True -- correct by construction - EqE t s -> t ==# s -- compare terms modulo AC - Last i -> Last i `S.member` get sAtoms se - DedBefore t (Lit (Var i)) -> t `dedBefore` i - Less (Lit (Var i)) (Lit (Var j)) -> i `hapBefore` j - EdgeA (Lit (Var i), v) (Lit (Var j), u) -> - Edge (NodeConc (i, v)) (NodePrem (j, u)) `S.member` get sEdges se + Action _ _ -> True -- correct by construction + EqE t s -> t == s -- compare terms modulo AC + Last i -> Last i `S.member` get sAtoms se + DedBefore t (viewTerm -> Lit (Var i)) -> t `dedBefore` i + Less (viewTerm -> Lit (Var i)) (viewTerm -> Lit (Var j)) -> i `hapBefore` j + EdgeA (viewTerm -> Lit (Var i), v) (viewTerm -> Lit (Var j), u) -> + Edge (i, v) (j, u) `S.member` get sEdges se -- play it safe and sound: all other atoms don't hold - _ -> False + _ -> False -- Find open goals @@ -200,7 +201,7 @@ -------------------------------------------------- skolemizeTerm :: VTerm Name LVar -> SkTerm skolemizeTerm :: LNTerm -> SkTerm -skolemizeTerm = fmap conv +skolemizeTerm = fmapTerm conv where conv :: Lit Name LVar -> Lit SkConst LVar conv (Var v) = Con (SkConst v) @@ -216,7 +217,7 @@ skolemizeGuarded = mapGuardedAtoms (const skolemizeAtom) unskolemizeTerm :: SkTerm -> VTerm Name LVar -unskolemizeTerm t = fmap conv t +unskolemizeTerm t = fmapTerm conv t where conv :: Lit SkConst LVar -> Lit Name LVar conv (Con (SkConst x)) = Var x @@ -238,7 +239,7 @@ ---------------------------------------------- skolemizeBTerm :: VTerm Name BLVar -> BSkTerm -skolemizeBTerm = fmap conv +skolemizeBTerm = fmapTerm conv where conv :: Lit Name BLVar -> Lit SkConst BLVar conv (Var (Free x)) = Con (SkConst x) @@ -246,7 +247,7 @@ conv (Con n) = Con (SkName n) unskolemizeBTerm :: BSkTerm -> VTerm Name BLVar -unskolemizeBTerm t = fmap conv t +unskolemizeBTerm t = fmapTerm conv t where conv :: Lit SkConst BLVar -> Lit Name BLVar conv (Con (SkConst x)) = Var (Free x) @@ -262,12 +263,14 @@ unskolemizeLNGuarded = mapGuardedAtoms (const unskolemizeBLAtom) applyBSkTerm :: SkSubst -> VTerm SkConst BLVar -> VTerm SkConst BLVar -applyBSkTerm subst t = (>>= applyBLLit) t +applyBSkTerm subst t = go t where + go (viewTerm -> Lit l) = applyBLLit l + go (viewTerm -> FApp o as) = fApp o (map go as) applyBLLit :: Lit SkConst BLVar -> VTerm SkConst BLVar applyBLLit l@(Var (Free v)) = - maybe (Lit l) (fmap (fmap Free)) (imageOf subst v) - applyBLLit l = Lit l + maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v) + applyBLLit l = lit l applyBSkAtom :: SkSubst -> Atom (VTerm SkConst BLVar) -> Atom (VTerm SkConst BLVar) applyBSkAtom subst = fmap (applyBSkTerm subst) diff --git a/src/Theory/Proof/Types.hs b/src/Theory/Proof/Types.hs --- a/src/Theory/Proof/Types.hs +++ b/src/Theory/Proof/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable, TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, ViewPatterns #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE) @@ -14,8 +15,8 @@ -- * Graph part of a sequent NodeId - , NodePrem(..) - , NodeConc(..) + , NodePrem + , NodeConc , Edge(..) , MsgEdge(..) , Chain(..) @@ -39,6 +40,13 @@ -- * Goals , Goal(..) + , isActionGoal + , isPremiseGoal + , isPremDnKGoal + , isPremUpKGoal + , isChainGoal + , isSplitGoal + , isDisjGoal -- * Keeping track of typing , CaseDistKind(..) @@ -67,6 +75,7 @@ , sLastAtoms , sDedBeforeAtoms , sActions + , sRawEdgeRel , sRawLessRel , sRawGreaterRel , deducibleBefore @@ -99,11 +108,15 @@ -- * Proof context , ProofContext(..) + , InductionHint(..) + , SequentTraceQuantifier(..) , pcSignature , pcRules , pcCaseDists - + , pcCaseDistKind + , pcUseInduction + , pcTraceQuantifier -- ** Classified rules , ClassifiedRules(..) @@ -111,15 +124,12 @@ , crConstruct , crDestruct , crProtocol - , crSpecial , joinAllRules - , joinNonSpecialRules , nonSilentRules -- ** Big-step case distinctions -- | See the module "Theory.Proof.CaseDistinction" for ways -- to construct case distinctions. - , BigStepGoal(..) , CaseDistinction(..) , cdGoal @@ -135,8 +145,6 @@ import Prelude hiding ( (.), id ) -import Safe - import Data.Maybe (mapMaybe, fromMaybe) import qualified Data.Set as S import qualified Data.Map as M @@ -152,7 +160,7 @@ import Control.Category import Control.Basics -import Text.Isar +import Text.PrettyPrint.Class import Logic.Connectives @@ -170,13 +178,11 @@ -- rules modulo AC. We identify these nodes using 'NodeId's. type NodeId = LVar --- | A premise (index) of a node. -newtype NodePrem = NodePrem { getNodePrem :: (NodeId, Int) } - deriving( Eq, Ord, Show, Data, Typeable ) +-- | A premise of a node. +type NodePrem = (NodeId, PremIdx) --- | A conclusion (index) of a node. -newtype NodeConc = NodeConc { getNodeConc :: (NodeId, Int) } - deriving( Eq, Ord, Show, Data, Typeable ) +-- | A conclusion of a node. +type NodeConc = (NodeId, ConcIdx) -- | A labeled edge in a derivation graph. data Edge = Edge { @@ -203,12 +209,6 @@ -- Instances ------------ -instance Apply NodePrem where - apply subst = NodePrem . first (apply subst) . getNodePrem - -instance Apply NodeConc where - apply subst = NodeConc . first (apply subst) . getNodeConc - instance Apply Edge where apply subst (Edge from to) = Edge (apply subst from) (apply subst to) @@ -218,16 +218,6 @@ instance Apply Chain where apply subst (Chain from to) = Chain (apply subst from) (apply subst to) -instance HasFrees NodePrem where - foldFrees f = foldFrees f . fst . getNodePrem - mapFrees f (NodePrem (v, i)) = - NodePrem <$> ((,) <$> mapFrees f v <*> pure i) - -instance HasFrees NodeConc where - foldFrees f = foldFrees f . fst . getNodeConc - mapFrees f (NodeConc (v, i)) = - NodeConc <$> ((,) <$> mapFrees f v <*> pure i) - instance HasFrees Edge where foldFrees f (Edge x y) = foldFrees f x `mappend` foldFrees f y mapFrees f (Edge x y) = Edge <$> mapFrees f x <*> mapFrees f y @@ -274,7 +264,7 @@ -- @s@ in the disjunction with @x `elem` dom s@. data EqStore = EqStore { _eqsSubst :: LNSubst - , _eqsConj :: Conj (Disj (LNSubstVFresh)) + , _eqsConj :: Conj (S.Set LNSubstVFresh) } deriving( Eq, Ord ) @@ -289,8 +279,8 @@ eqsIsFalse = (== falseEqConstrConj) . L.get eqsConj -- | The false typing conjunction. -falseEqConstrConj :: Conj (Disj (LNSubstVFresh)) -falseEqConstrConj = Conj [(Disj [])] +falseEqConstrConj :: Conj (S.Set (LNSubstVFresh)) +falseEqConstrConj = Conj [S.empty] -- Instances @@ -316,8 +306,11 @@ data Goal = ActionG LVar LNFact -- ^ An action that must exist in the trace. - | PremiseG NodePrem LNFact - -- ^ A premise that must have an incoming direct edge. + | PremiseG NodePrem LNFact Bool + -- ^ A premise that must have an incoming direct edge. The 'Bool' + -- argument is 'True' if this premise is marked as a loop-breaker; + -- i.e., if care must be taken to avoid solving such a premise too + -- often. | PremDnKG NodePrem -- ^ A KD goal that must be solved using a destruction chain. | PremUpKG NodePrem LNTerm @@ -336,40 +329,73 @@ -- out. deriving( Eq, Ord, Show ) +-- Indicators +------------- + +isActionGoal :: Goal -> Bool +isActionGoal (ActionG _ _) = True +isActionGoal _ = False + +isPremiseGoal :: Goal -> Bool +isPremiseGoal (PremiseG _ _ _) = True +isPremiseGoal _ = False + +isPremDnKGoal :: Goal -> Bool +isPremDnKGoal (PremDnKG _) = True +isPremDnKGoal _ = False + +isPremUpKGoal :: Goal -> Bool +isPremUpKGoal (PremUpKG _ _) = True +isPremUpKGoal _ = False + +isChainGoal :: Goal -> Bool +isChainGoal (ChainG _) = True +isChainGoal _ = False + +isSplitGoal :: Goal -> Bool +isSplitGoal (SplitG _) = True +isSplitGoal _ = False + +isDisjGoal :: Goal -> Bool +isDisjGoal (DisjG _) = True +isDisjGoal _ = False + + + -- Instances ------------ instance HasFrees Goal where foldFrees f goal = case goal of - ActionG i fa -> foldFrees f i `mappend` foldFrees f fa - PremiseG p fa -> foldFrees f p `mappend` foldFrees f fa - PremDnKG p -> foldFrees f p - PremUpKG p m -> foldFrees f p `mappend` foldFrees f m - ChainG ch -> foldFrees f ch - SplitG i -> foldFrees f i - DisjG x -> foldFrees f x - ImplG x -> foldFrees f x + ActionG i fa -> foldFrees f i `mappend` foldFrees f fa + PremiseG p fa mayLoop -> foldFrees f p `mappend` foldFrees f fa `mappend` foldFrees f mayLoop + PremDnKG p -> foldFrees f p + PremUpKG p m -> foldFrees f p `mappend` foldFrees f m + ChainG ch -> foldFrees f ch + SplitG i -> foldFrees f i + DisjG x -> foldFrees f x + ImplG x -> foldFrees f x mapFrees f goal = case goal of - ActionG i fa -> ActionG <$> mapFrees f i <*> mapFrees f fa - PremiseG p fa -> PremiseG <$> mapFrees f p <*> mapFrees f fa - PremDnKG p -> PremDnKG <$> mapFrees f p - PremUpKG p m -> PremUpKG <$> mapFrees f p <*> mapFrees f m - ChainG ch -> ChainG <$> mapFrees f ch - SplitG i -> SplitG <$> mapFrees f i - DisjG x -> DisjG <$> mapFrees f x - ImplG x -> ImplG <$> mapFrees f x + ActionG i fa -> ActionG <$> mapFrees f i <*> mapFrees f fa + PremiseG p fa mayLoop -> PremiseG <$> mapFrees f p <*> mapFrees f fa <*> mapFrees f mayLoop + PremDnKG p -> PremDnKG <$> mapFrees f p + PremUpKG p m -> PremUpKG <$> mapFrees f p <*> mapFrees f m + ChainG ch -> ChainG <$> mapFrees f ch + SplitG i -> SplitG <$> mapFrees f i + DisjG x -> DisjG <$> mapFrees f x + ImplG x -> ImplG <$> mapFrees f x instance Apply Goal where apply subst goal = case goal of - ActionG i fa -> ActionG (apply subst i) (apply subst fa) - PremiseG p fa -> PremiseG (apply subst p) (apply subst fa) - PremDnKG p -> PremDnKG (apply subst p) - PremUpKG p m -> PremUpKG (apply subst p) (apply subst m) - ChainG ch -> ChainG (apply subst ch) - SplitG i -> SplitG (apply subst i) - DisjG x -> DisjG (apply subst x) - ImplG x -> ImplG (apply subst x) + ActionG i fa -> ActionG (apply subst i) (apply subst fa) + PremiseG p fa mayLoop -> PremiseG (apply subst p) (apply subst fa) (apply subst mayLoop) + PremDnKG p -> PremDnKG (apply subst p) + PremUpKG p m -> PremUpKG (apply subst p) (apply subst m) + ChainG ch -> ChainG (apply subst ch) + SplitG i -> SplitG (apply subst i) + DisjG x -> DisjG (apply subst x) + ImplG x -> ImplG (apply subst x) ------------------------------------------------------------------------------ @@ -449,33 +475,37 @@ malformed ato = error $ "malformed atom in sequent: " ++ show ato - aLess (Less (Lit (Var from)) (Lit (Var to))) = Just (from, to) + aLess (Less (viewTerm -> Lit (Var from)) (viewTerm -> Lit (Var to))) = Just (from, to) aLess ato@(Less _ _) = malformed ato aLess _ = Nothing - aAction (Action (Lit (Var i)) fa) = Just (i, fa) + aAction (Action (viewTerm -> Lit (Var i)) fa) = Just (i, fa) aAction ato@(Action _ _) = malformed ato aAction _ = Nothing - aLast (Last (Lit (Var i))) = Just i + aLast (Last (viewTerm -> Lit (Var i))) = Just i aLast ato@(Last _) = malformed ato aLast _ = Nothing - aDedBefore (DedBefore t (Lit (Var i))) = Just (t, i) + aDedBefore (DedBefore t (viewTerm -> Lit (Var i))) = Just (t, i) aDedBefore ato@(DedBefore _ _) = malformed ato aDedBefore _ = Nothing - --- | @(from,to)@ is in @sRawLessRel se@ iff we can prove that there is a path --- from @from@ to @to@ in @se@ without appealing to transitivity. -sRawLessRel :: Sequent -> [(NodeId,NodeId)] -sRawLessRel se = - sLessAtoms se ++ +-- | @(from,to)@ is in @sRawEdgeRel se@ iff we can prove that there is an +-- edge-path from @from@ to @to@ in @se@ without appealing to transitivity. +sRawEdgeRel :: Sequent -> [(NodeId, NodeId)] +sRawEdgeRel se = map (nodeConcNode *** nodePremNode) ([ (from, to) | Edge from to <- S.toList $ L.get sEdges se ] ++ [ (from, to) | MsgEdge from to <- S.toList $ L.get sMsgEdges se ] ++ [ (from, to) | Chain from to <- S.toList $ L.get sChains se ]) +-- | @(from,to)@ is in @sRawLessRel se@ iff we can prove that there is a path +-- (possibly using the 'Less' relation) from @from@ to @to@ in @se@ without +-- appealing to transitivity. +sRawLessRel :: Sequent -> [(NodeId,NodeId)] +sRawLessRel se = sLessAtoms se ++ sRawEdgeRel se + -- | 'sRawGreaterRel' is the inverse of 'sRawLessRel'. sRawGreaterRel :: Sequent -> [(NodeId,NodeId)] sRawGreaterRel = map (\(x,y) -> (y,x)) . sRawLessRel @@ -554,16 +584,15 @@ -- sequent @se@ under the assumption that premise @prem@ is a a premise in -- @se@. nodePremFact :: NodePrem -> Sequent -> LNFact -nodePremFact (NodePrem (v, i)) se = L.get (rPrem i) $ nodeRule v se +nodePremFact (v, i) se = L.get (rPrem i) $ nodeRule v se -- | @nodePremNode prem@ is the node that this premise is referring to. nodePremNode :: NodePrem -> NodeId -nodePremNode (NodePrem (v, _)) = v +nodePremNode = fst -- | All facts associated to this node premise. resolveNodePremFact :: NodePrem -> Sequent -> Maybe LNFact -resolveNodePremFact (NodePrem (v, i)) se = - (`atMay` i) =<< L.get rPrems <$> M.lookup v (L.get sNodes se) +resolveNodePremFact (v, i) se = lookupPrem i =<< M.lookup v (L.get sNodes se) {- -- | All msg fact premises required by the sequent for the given node premise. @@ -573,8 +602,7 @@ -- | The fact associated with this node conclusion, if there is one. resolveNodeConcFact :: NodeConc -> Sequent -> Maybe LNFact -resolveNodeConcFact (NodeConc (v, i)) se = - (`atMay` i) =<< L.get rConcs <$> M.lookup v (L.get sNodes se) +resolveNodeConcFact (v, i) se = lookupConc i =<< M.lookup v (L.get sNodes se) {- -- | The msg fact provided by the sequent for the given node conclusion @@ -586,11 +614,11 @@ -- rule associated with node @v@ under the assumption that @v@ is labeled with -- a rule that has an @i@-th conclusion. nodeConcFact :: NodeConc -> Sequent -> LNFact -nodeConcFact (NodeConc (v, i)) = L.get (rConc i) . nodeRule v +nodeConcFact (v, i) = L.get (rConc i) . nodeRule v -- | 'nodeConcNode' @c@ compute the node-id of the node conclusion @c@. nodeConcNode :: NodeConc -> NodeId -nodeConcNode = fst . getNodeConc +nodeConcNode = fst -- | Label to access the free substitution of the equation store. sSubst :: Sequent :-> LNSubst @@ -598,7 +626,7 @@ -- | Label to access the conjunction of disjunctions of fresh substutitution in -- the equation store. -sConjDisjEqs :: Sequent :-> Conj (Disj (LNSubstVFresh)) +sConjDisjEqs :: Sequent :-> Conj (S.Set (LNSubstVFresh)) sConjDisjEqs = eqsConj . sEqStore @@ -616,11 +644,11 @@ -- | Pretty print a node conclusion. prettyNodeConc :: HighlightDocument d => NodeConc -> d -prettyNodeConc (NodeConc (v, i)) = parens (prettyNodeId v <> comma <-> int i) +prettyNodeConc (v, ConcIdx i) = parens (prettyNodeId v <> comma <-> int i) -- | Pretty print a node premise. prettyNodePrem :: HighlightDocument d => NodePrem -> d -prettyNodePrem (NodePrem (v, i)) = parens (prettyNodeId v <> comma <-> int i) +prettyNodePrem (v, PremIdx i) = parens (prettyNodeId v <> comma <-> int i) -- | Pretty print a edge as @src >-i--j-> tgt@. prettyEdge :: HighlightDocument d => Edge -> d @@ -677,21 +705,23 @@ ] where combine (header, d) = fsep [keyword_ header <> colon, nest 2 d] - ppDisj (Disj substs) = + ppDisj substs = numbered' conjs where - conjs = map ppConj substs + conjs = map ppConj (S.toList substs) ppConj = vcat . map prettyEq . substToListVFresh prettyEq (a,b) = - prettyNTerm (Lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b) + prettyNTerm (lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b) -- | Pretty print a goal. prettyGoal :: HighlightDocument d => Goal -> d -prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa) -prettyGoal (ChainG ch) = prettyChain ch -prettyGoal (PremiseG p fa) = prettyNodePrem p <> brackets (prettyLNFact fa) -prettyGoal (PremDnKG p) = text "KD" <> parens (prettyNodePrem p) -prettyGoal (ImplG gf) = +prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa) +prettyGoal (ChainG ch) = prettyChain ch +prettyGoal (PremiseG p fa mayLoop) = + prettyNodePrem p <> brackets (prettyLNFact fa) <-> + (if mayLoop then comment_ "/* may loop */" else emptyDoc) +prettyGoal (PremDnKG p) = text "KD" <> parens (prettyNodePrem p) +prettyGoal (ImplG gf) = (text "Consequent" <>) $ nest 1 $ parens $ prettyGuarded gf prettyGoal (DisjG (Disj gfs)) = (text "Disj" <>) $ fsep $ punctuate (operator_ " |") (map (nest 1 . parens . prettyGuarded) gfs) @@ -700,6 +730,7 @@ prettyGoal (SplitG x) = text "splitEqs" <> parens (text $ show (succ x)) + -- Additional Show instances moved here due to TemplateHaskell splicing rules ----------------------------------------------------------------------------- @@ -716,8 +747,6 @@ { _crProtocol :: [RuleAC] -- all protocol rules , _crDestruct :: [RuleAC] -- destruction rules , _crConstruct :: [RuleAC] -- construction rules - , _crSpecial :: [RuleAC] -- rules that are handled by other means - -- than unification. } deriving( Eq, Ord, Show ) @@ -725,47 +754,49 @@ -- | The empty proof rule set. emptyClassifiedRules :: ClassifiedRules -emptyClassifiedRules = ClassifiedRules [] [] [] [] - --- | @joinNonSpecialRules rules@ computes the union of all non-special @rules@. -joinNonSpecialRules :: ClassifiedRules -> [RuleAC] -joinNonSpecialRules (ClassifiedRules a b c _) = a ++ b ++ c +emptyClassifiedRules = ClassifiedRules [] [] [] -- | @joinAllRules rules@ computes the union of all rules classified in -- @rules@. joinAllRules :: ClassifiedRules -> [RuleAC] -joinAllRules (ClassifiedRules a b c d) = a ++ b ++ c ++ d +joinAllRules (ClassifiedRules a b c) = a ++ b ++ c -- | Extract all non-silent rules. nonSilentRules :: ClassifiedRules -> [RuleAC] -nonSilentRules = filter (not . null . L.get rActs) . L.get crProtocol +nonSilentRules = filter (not . null . L.get rActs) . joinAllRules ------------------------------------------------------------------------------ -- Proof Context ------------------------------------------------------------------------------ --- | A goal for a big step case distinction. -data BigStepGoal = - PremiseBigStep LNFact - | MessageBigStep LNTerm - deriving( Eq, Ord, Show ) - -- | A big-step case distinction. data CaseDistinction = CaseDistinction - { _cdGoal :: BigStepGoal -- start goal of case distinction + { _cdGoal :: LNFact -- start goal of case distinction -- disjunction of named sequents with premise being solved; each name -- being the path of proof steps required to arrive at these cases , _cdCases :: Disj ([String], (NodeConc, Sequent)) } deriving( Eq, Ord, Show ) +-- | Whether we are checking for the existence of a trace satisfiying a the +-- current constraint system or whether we're checking that no traces +-- satisfies the current constraint system. +data SequentTraceQuantifier = ExistsSomeTrace | ExistsNoTrace + deriving( Eq, Ord, Show ) + +data InductionHint = UseInduction | AvoidInduction + deriving( Eq, Ord, Show ) + -- | A proof context contains the globally fresh facts, classified rewrite -- rules and the corresponding precomputed premise case distinction theorems. data ProofContext = ProofContext - { _pcSignature :: SignatureWithMaude - , _pcRules :: ClassifiedRules - , _pcCaseDists :: [CaseDistinction] + { _pcSignature :: SignatureWithMaude + , _pcRules :: ClassifiedRules + , _pcCaseDistKind :: CaseDistKind + , _pcCaseDists :: [CaseDistinction] + , _pcUseInduction :: InductionHint + , _pcTraceQuantifier :: SequentTraceQuantifier } deriving( Eq, Ord, Show ) @@ -784,20 +815,6 @@ <*> mapFrees f (L.get cdCases th) --- Instances ------------- - -instance HasFrees BigStepGoal where - foldFrees f (PremiseBigStep fa) = foldFrees f fa - foldFrees f (MessageBigStep m) = foldFrees f m - - mapFrees f (PremiseBigStep fa) = PremiseBigStep <$> mapFrees f fa - mapFrees f (MessageBigStep m) = MessageBigStep <$> mapFrees f m - -instance Apply BigStepGoal where - apply subst (PremiseBigStep fa) = PremiseBigStep (apply subst fa) - apply subst (MessageBigStep m) = MessageBigStep (apply subst m) - -- NFData --------- @@ -805,24 +822,22 @@ $( derive makeBinary ''Chain) $( derive makeBinary ''MsgEdge) $( derive makeBinary ''Edge) -$( derive makeBinary ''NodePrem) -$( derive makeBinary ''NodeConc) $( derive makeBinary ''EqStore) $( derive makeBinary ''CaseDistKind) $( derive makeBinary ''Sequent) -$( derive makeBinary ''BigStepGoal) $( derive makeBinary ''CaseDistinction) $( derive makeBinary ''ClassifiedRules) +$( derive makeBinary ''SequentTraceQuantifier) +$( derive makeBinary ''InductionHint) $( derive makeNFData ''Goal) $( derive makeNFData ''Chain) $( derive makeNFData ''MsgEdge) $( derive makeNFData ''Edge) -$( derive makeNFData ''NodePrem) -$( derive makeNFData ''NodeConc) $( derive makeNFData ''EqStore) $( derive makeNFData ''CaseDistKind) $( derive makeNFData ''Sequent) -$( derive makeNFData ''BigStepGoal) $( derive makeNFData ''CaseDistinction) $( derive makeNFData ''ClassifiedRules) +$( derive makeNFData ''SequentTraceQuantifier) +$( derive makeNFData ''InductionHint) diff --git a/src/Theory/Rule.hs b/src/Theory/Rule.hs --- a/src/Theory/Rule.hs +++ b/src/Theory/Rule.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TupleSections, TypeOperators, FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable, TupleSections, TypeOperators, FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE) @@ -11,6 +11,8 @@ module Theory.Rule ( -- * General Rules Rule(..) + , PremIdx(..) + , ConcIdx(..) -- ** Accessors , rInfo @@ -19,9 +21,10 @@ , rActs , rPrem , rConc - , rAct , lookupPrem , lookupConc + , enumPrems + , enumConcs -- ** Genereal protocol and intruder rules , RuleInfo(..) @@ -30,6 +33,12 @@ -- * Protocol Rule Information , ProtoRuleName(..) , ProtoRuleACInfo(..) + , pracName + , pracVariants + , pracLoopBreakers + , ProtoRuleACInstInfo(..) + , praciName + , praciLoopBreakers , RuleACConstrs -- * Intruder Rule Information @@ -44,6 +53,7 @@ -- ** Queries , HasRuleName(..) + , isIntruderRule , isDestrRule , isConstrRule , isFreshRule @@ -51,7 +61,7 @@ , isISendRule , isCoerceRule , nfRule - , isTrivialProtoRuleAC + , isTrivialProtoVariantAC -- ** Conversion , ruleACToIntrRuleAC @@ -72,6 +82,7 @@ , prettyIntrRuleAC , prettyIntrRuleACInfo , prettyRuleAC + , prettyLoopBreakers , prettyRuleACInst -- * Convenience exports @@ -119,26 +130,38 @@ $(mkLabels [''Rule]) +-- | An index of a premise. The first premise has index '0'. +newtype PremIdx = PremIdx { getPremIdx :: Int } + deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData ) + +-- | An index of a conclusion. The first conclusion has index '0'. +newtype ConcIdx = ConcIdx { getConcIdx :: Int } + deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData ) + -- | @lookupPrem i ru@ returns the @i@-th premise of rule @ru@, if possible. -lookupPrem :: Int -> Rule i -> Maybe LNFact -lookupPrem i = (`atMay` i) . L.get rPrems +lookupPrem :: PremIdx -> Rule i -> Maybe LNFact +lookupPrem i = (`atMay` getPremIdx i) . L.get rPrems -- | @lookupConc i ru@ returns the @i@-th conclusion of rule @ru@, if possible. -lookupConc :: Int -> Rule i -> Maybe LNFact -lookupConc i = (`atMay` i) . L.get rConcs +lookupConc :: ConcIdx -> Rule i -> Maybe LNFact +lookupConc i = (`atMay` getConcIdx i) . L.get rConcs -- | @rPrem i@ is a lens for the @i@-th premise of a rule. -rPrem :: Int -> (Rule i :-> LNFact) -rPrem i = nthL i . rPrems +rPrem :: PremIdx -> (Rule i :-> LNFact) +rPrem i = nthL (getPremIdx i) . rPrems -- | @rConc i@ is a lens for the @i@-th conclusion of a rule. -rConc :: Int -> (Rule i :-> LNFact) -rConc i = nthL i . rConcs +rConc :: ConcIdx -> (Rule i :-> LNFact) +rConc i = nthL (getConcIdx i) . rConcs --- | @rAct i@ is a lens for the @i@-th action of a rule. -rAct :: Int -> (Rule i :-> LNFact) -rAct i = nthL i . rActs +-- | Enumerate all premises of a rule. +enumPrems :: Rule i -> [(PremIdx, LNFact)] +enumPrems = zip [(PremIdx 0)..] . L.get rPrems +-- | Enumerate all conclusions of a rule. +enumConcs :: Rule i -> [(ConcIdx, LNFact)] +enumConcs = zip [(ConcIdx 0)..] . L.get rConcs + -- Instances ------------ @@ -200,10 +223,7 @@ -- | A name of a protocol rule is either one of the special reserved rules or -- some standard rule. data ProtoRuleName = - -- FIXME: Consider also moving them to intruder/model rules. FreshRule - | IRecvRule - | ISendRule | StandRule String -- ^ Some standard protocol rule deriving( Eq, Ord, Show, Data, Typeable ) @@ -212,12 +232,23 @@ -- instantiations of the free variables of the rule. The typing is interpreted -- modulo AC; i.e., its variants were also built. data ProtoRuleACInfo = ProtoRuleACInfo - { pracName :: ProtoRuleName - , pracVariants :: Disj (LNSubstVFresh) + { _pracName :: ProtoRuleName + , _pracVariants :: Disj (LNSubstVFresh) + , _pracLoopBreakers :: [PremIdx] } deriving( Eq, Ord, Show ) +-- | Information for instances of protocol rules modulo AC. +data ProtoRuleACInstInfo = ProtoRuleACInstInfo + { _praciName :: ProtoRuleName + , _praciLoopBreakers :: [PremIdx] + } + deriving( Eq, Ord, Show ) + +$(mkLabels [''ProtoRuleACInfo, ''ProtoRuleACInstInfo]) + + -- Instances ------------ @@ -228,21 +259,52 @@ foldFrees _ = const mempty mapFrees _ = pure +instance Apply PremIdx where + apply _ = id +instance HasFrees PremIdx where + foldFrees _ = const mempty + mapFrees _ = pure + +instance Apply ConcIdx where + apply _ = id + +instance HasFrees ConcIdx where + foldFrees _ = const mempty + mapFrees _ = pure + instance HasFrees ProtoRuleACInfo where - foldFrees f (ProtoRuleACInfo na vari) = + foldFrees f (ProtoRuleACInfo na vari breakers) = foldFrees f na `mappend` foldFrees f vari + `mappend` foldFrees f breakers - mapFrees f (ProtoRuleACInfo na vari) = - ProtoRuleACInfo na <$> mapFrees f vari + mapFrees f (ProtoRuleACInfo na vari breakers) = + ProtoRuleACInfo na <$> mapFrees f vari <*> mapFrees f breakers +instance Apply ProtoRuleACInstInfo where + apply _ = id +instance HasFrees ProtoRuleACInstInfo where + foldFrees f (ProtoRuleACInstInfo na breakers) = + foldFrees f na `mappend` foldFrees f breakers + + mapFrees f (ProtoRuleACInstInfo na breakers) = + ProtoRuleACInstInfo na <$> mapFrees f breakers + + ------------------------------------------------------------------------------ -- Intruder Rule Information ------------------------------------------------------------------------------ -- | An intruder rule modulo AC is described by its name. -data IntrRuleACInfo = IntrApp String | CoerceRule +data IntrRuleACInfo = + ConstrRule String + | DestrRule String + | CoerceRule + | IRecvRule + | ISendRule + | PubConstrRule + | FreshConstrRule deriving( Ord, Eq, Show, Data, Typeable ) -- | An intruder rule modulo AC. @@ -286,7 +348,7 @@ -- | A rule instance module AC is either a protocol rule or an intruder rule. -- The info identifies the corresponding rule modulo AC that the instance was -- derived from. -type RuleACInst = Rule (RuleInfo ProtoRuleName IntrRuleACInfo) +type RuleACInst = Rule (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) -- Accessing the rule name -------------------------- @@ -299,32 +361,35 @@ ruleName = ProtoInfo . L.get rInfo instance HasRuleName RuleAC where - ruleName = ruleInfo (ProtoInfo . pracName) IntrInfo . L.get rInfo + ruleName = ruleInfo (ProtoInfo . L.get pracName) IntrInfo . L.get rInfo instance HasRuleName ProtoRuleAC where - ruleName = ProtoInfo . pracName . L.get rInfo + ruleName = ProtoInfo . L.get (pracName . rInfo) instance HasRuleName IntrRuleAC where ruleName = IntrInfo . L.get rInfo instance HasRuleName RuleACInst where - ruleName = L.get rInfo + ruleName = ruleInfo (ProtoInfo . L.get praciName) IntrInfo . L.get rInfo -- Queries ---------- -- | True iff the rule is a destruction rule. -isDestrRule :: Rule r -> Bool -isDestrRule ru = case kFactView <$> L.get rConcs ru of - [Just (DnK, _, _)] -> True - _ -> False +isDestrRule :: HasRuleName r => r -> Bool +isDestrRule ru = case ruleName ru of + IntrInfo (DestrRule _) -> True + _ -> False -- | True iff the rule is a construction rule. -isConstrRule :: Rule r -> Bool -isConstrRule ru = case kFactView <$> L.get rConcs ru of - [Just (UpK, _, _)] -> True - _ -> False +isConstrRule :: HasRuleName r => r -> Bool +isConstrRule ru = case ruleName ru of + IntrInfo (ConstrRule _) -> True + IntrInfo FreshConstrRule -> True + IntrInfo PubConstrRule -> True + IntrInfo CoerceRule -> True + _ -> False -- | True iff the rule is the special fresh rule. isFreshRule :: HasRuleName r => r -> Bool @@ -332,11 +397,11 @@ -- | True iff the rule is the special learn rule. isIRecvRule :: HasRuleName r => r -> Bool -isIRecvRule = (ProtoInfo IRecvRule ==) . ruleName +isIRecvRule = (IntrInfo IRecvRule ==) . ruleName -- | True iff the rule is the special knows rule. isISendRule :: HasRuleName r => r -> Bool -isISendRule = (ProtoInfo ISendRule ==) . ruleName +isISendRule = (IntrInfo ISendRule ==) . ruleName -- | True iff the rule is the special coerce rule. isCoerceRule :: HasRuleName r => r -> Bool @@ -350,29 +415,37 @@ nfFactList hnd xs = getAll $ foldMap (foldMap (All . (\t -> nf' t `runReader` hnd))) xs --- | True if the protocol rule has no variants. -isTrivialProtoRuleAC :: ProtoRuleAC -> Bool -isTrivialProtoRuleAC (Rule info _ _ _) = - pracVariants info == Disj [emptySubstVFresh] +-- | True iff the rule is an intruder rule +isIntruderRule :: HasRuleName r => r -> Bool +isIntruderRule ru = + case ruleName ru of IntrInfo _ -> True; ProtoInfo _ -> False +-- | True if the protocol rule has only the trivial variant. +isTrivialProtoVariantAC :: ProtoRuleAC -> ProtoRuleE -> Bool +isTrivialProtoVariantAC (Rule info ps as cs) (Rule _ ps' as' cs') = + L.get pracVariants info == Disj [emptySubstVFresh] + && ps == ps' && as == as' && cs == cs' + -- Construction --------------- -type RuleACConstrs = Disj (LNSubstVFresh) +type RuleACConstrs = Disj LNSubstVFresh -- | Compute /some/ rule instance of a rule modulo AC. If the rule is a --- protocol rule, then the given typing and variants also need to handled. +-- protocol rule, then the given typing and variants also need to be handled. someRuleACInst :: MonadFresh m => RuleAC -> m (RuleACInst, Maybe RuleACConstrs) someRuleACInst = - (`evalBindT` noBindings) . fmap extractInsts . someInst + fmap extractInsts . rename where extractInsts (Rule (ProtoInfo i) ps cs as) = - ( Rule (ProtoInfo (pracName i)) ps cs as - , Just (pracVariants i) + ( Rule (ProtoInfo i') ps cs as + , Just (L.get pracVariants i) ) + where + i' = ProtoRuleACInstInfo (L.get pracName i) (L.get pracLoopBreakers i) extractInsts (Rule (IntrInfo i) ps cs as) = ( Rule (IntrInfo i) ps cs as, Nothing ) @@ -448,15 +521,19 @@ -- Pretty-Printing ------------------------------------------------------------------------------ +-- | Prefix the name if it is equal to a reserved name. +prefixIfReserved :: String -> String +prefixIfReserved n + | n `elem` reserved = "_" ++ n + | "_" `isPrefixOf` n = "_" ++ n + | otherwise = n + where + reserved = ["Fresh", "irecv", "isend", "coerce", "fresh", "pub"] + prettyProtoRuleName :: Document d => ProtoRuleName -> d prettyProtoRuleName rn = text $ case rn of - FreshRule -> "Fresh" - IRecvRule -> "IRecv" - ISendRule -> "ISend" - StandRule n - | n `elem` ["Fresh", "IRecv", "ISend"] -> "_" ++ n - | "_" `isPrefixOf` n -> "_" ++ n - | otherwise -> n + FreshRule -> "Fresh" + StandRule n -> prefixIfReserved n prettyRuleName :: (HighlightDocument d, HasRuleName (Rule i)) => Rule i -> d prettyRuleName = ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName @@ -467,8 +544,14 @@ render . ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName prettyIntrRuleACInfo :: Document d => IntrRuleACInfo -> d -prettyIntrRuleACInfo (IntrApp name) = text $ name -prettyIntrRuleACInfo CoerceRule = text "coerce" +prettyIntrRuleACInfo rn = text $ case rn of + IRecvRule -> "irecv" + ISendRule -> "isend" + CoerceRule -> "coerce" + FreshConstrRule -> "fresh" + PubConstrRule -> "pub" + ConstrRule name -> prefixIfReserved ('c' : name) + DestrRule name -> prefixIfReserved ('d' : name) prettyNamedRule :: (HighlightDocument d, HasRuleName (Rule i)) => d -- ^ Prefix. @@ -489,11 +572,20 @@ prettyProtoRuleACInfo :: HighlightDocument d => ProtoRuleACInfo -> d prettyProtoRuleACInfo i = - (ppVariants $ pracVariants i) + (ppVariants $ L.get pracVariants i) $-$ + prettyLoopBreakers i where ppVariants (Disj [subst]) | subst == emptySubstVFresh = emptyDoc ppVariants substs = kwVariantsModulo "AC" $-$ prettyDisjLNSubstsVFresh substs +prettyLoopBreakers :: HighlightDocument d => ProtoRuleACInfo -> d +prettyLoopBreakers i = case breakers of + [] -> emptyDoc + [_] -> lineComment_ $ "loop breaker: " ++ show breakers + _ -> lineComment_ $ "loop breakers: " ++ show breakers + where + breakers = getPremIdx <$> L.get pracLoopBreakers i + prettyProtoRuleE :: HighlightDocument d => ProtoRuleE -> d prettyProtoRuleE = prettyNamedRule (kwRuleModulo "E") (const emptyDoc) @@ -517,11 +609,13 @@ $( derive makeBinary ''Rule) $( derive makeBinary ''ProtoRuleName) $( derive makeBinary ''ProtoRuleACInfo) +$( derive makeBinary ''ProtoRuleACInstInfo) $( derive makeBinary ''RuleInfo) $( derive makeBinary ''IntrRuleACInfo) $( derive makeNFData ''Rule) $( derive makeNFData ''ProtoRuleName) $( derive makeNFData ''ProtoRuleACInfo) +$( derive makeNFData ''ProtoRuleACInstInfo) $( derive makeNFData ''RuleInfo) $( derive makeNFData ''IntrRuleACInfo) diff --git a/src/Theory/RuleSet.hs b/src/Theory/RuleSet.hs new file mode 100644 --- /dev/null +++ b/src/Theory/RuleSet.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Copyright : (c) 2012 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- Portability : portable +-- +-- Computations over sets of rewriting rules. +module Theory.RuleSet ( + + -- * Computing loop breakers for solving premises + useAutoLoopBreakersAC + ) where + +import Control.Applicative +import Control.Monad.Fresh +import Control.Monad.Reader + +import Data.DAG.Simple + +import Theory.Rule + + +-- | An over-approximation of the dependency of solving premises. An element +-- @((fromRu, fromPrem), (toRu, toPrem))@ denotes that solving the premise +-- @(fromRu,fromPrem)@ might lead to a case where the premise @(toRu, toPrem)@ +-- is open. +premSolvingRelAC :: (a -> [(PremIdx, LNFact)]) -- ^ Enumerate premises + -> (a -> [(ConcIdx, LNFact)]) -- ^ Enumerate conclusions + -> (a -> [LNSubstVFresh]) -- ^ Enumerate variants + -> [a] -- ^ Base carrier + -> WithMaude (Relation (a, PremIdx)) +premSolvingRelAC ePrems eConcs eVariants rules = reader $ \hnd -> do + (toRu, from) <- dataflowRelAC hnd + (toPrem, _) <- ePrems toRu + return (from, (toRu, toPrem)) + where + -- An over-approxmiation of the dataflow relation. An element @(fromRu, + -- (toRu, toPrem))@ denotes that there is a conclusion of @fromRu@ + -- unifying with the premise @(toRu, toPrem)@. + dataflowRelAC hnd = do + ruFrom <- rules + ruTo <- rules + (premIdx, premFa0) <- ePrems ruTo + guard $ or $ do + premFa <- instances ruTo premFa0 + concFa <- instances ruFrom =<< (snd <$> eConcs ruFrom) + let concFaFresh = rename concFa `evalFresh` avoid premFa + return $ (`runReader` hnd) (unifiableLNFacts concFaFresh premFa) + return (ruFrom, (ruTo, premIdx)) + + instances ru fa = do + subst <- eVariants ru + return (apply (subst `freshToFreeAvoiding` fa) fa) + + +-- | Replace all loop-breaker information with loop-breakers computed +-- automatically from the dataflow relation 'dataflowRelAC'. +useAutoLoopBreakersAC + :: Ord a + => (a -> [(PremIdx, LNFact)]) -- ^ Enumerate premises + -> (a -> [(ConcIdx, LNFact)]) -- ^ Enumerate conclusions + -> (a -> [LNSubstVFresh]) -- ^ Enumerate variants + -> ([PremIdx] -> a -> a) -- ^ Add annotation + -> [a] -- ^ Original rules + -> WithMaude ([a], Relation (a, PremIdx), [(a, PremIdx)]) + -- ^ Annotated rules and the premise solving relation +useAutoLoopBreakersAC ePrems eConcs eVariants addAnn rules = + reader $ \hnd -> + let solveRel = (`runReader` hnd) $ + premSolvingRelAC ePrems eConcs eVariants rules + breakers = dfsLoopBreakers $ solveRel + in ( do ru <- rules + return (addAnn [ u | (ru', u) <- breakers, ru == ru' ] ru) + , solveRel + , breakers + ) + diff --git a/src/Theory/RuleVariants.hs b/src/Theory/RuleVariants.hs --- a/src/Theory/RuleVariants.hs +++ b/src/Theory/RuleVariants.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, StandaloneDeriving, TypeSynonymInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances, ViewPatterns, ScopedTypeVariables #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt -- License : GPL v3 (see LICENSE) @@ -19,10 +20,12 @@ import Control.Monad.Reader import Control.Monad.Bind +import qualified Control.Monad.Trans.PreciseFresh as Precise import Control.Applicative import qualified Data.Map as M import Data.Traversable (traverse) +import qualified Data.Set as S import Debug.Trace.Ignore @@ -38,14 +41,14 @@ variantsProtoRule :: MaudeHandle -> ProtoRuleE -> ProtoRuleAC variantsProtoRule hnd ru@(Rule ri prems0 concs0 acts0) = -- rename rule to decrease variable indices - (`evalFresh` nothingUsed) . rename $ convertRule `evalFreshAvoiding` ru + (`Precise.evalFresh` Precise.nothingUsed) . renamePrecise $ convertRule `evalFreshAvoiding` ru where convertRule = do (abstrPsCsAs, bindings) <- abstrRule let eqsAbstr = map swap (M.toList bindings) abstractedTerms = map snd eqsAbstr abstractionSubst = substFromList eqsAbstr - variantSubsts = computeVariants (listToTerm abstractedTerms) `runReader` hnd + variantSubsts = computeVariants (fAppList abstractedTerms) `runReader` hnd substs = [ restrictVFresh (frees abstrPsCsAs) $ removeRenamings $ ((`runReader` hnd) . normSubstVFresh') $ composeVFresh vsubst abstractionSubst @@ -55,7 +58,7 @@ [] -> error $ "variantsProtoRule: rule has no variants `"++show ru++"'" _ -> do -- x <- return (emptySubst, Just substs) -- - x <- simpDisjunction hnd (Disj substs) + x <- simpDisjunction hnd (const False) (Disj substs) case trace (show ("SIMP",abstractedTerms, "abstr", abstrPsCsAs, "substs", substs, @@ -72,13 +75,19 @@ (,,) <$> mapM abstrFact prems0 <*> mapM abstrFact concs0 <*> mapM abstrFact acts0 + + irreducible = irreducibleFunctionSymbols (mhMaudeSig hnd) abstrFact = traverse abstrTerm - abstrTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t) - where getHint (Lit (Var v)) = lvarName v - getHint _ = "z" + abstrTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible = + fAppNonAC o <$> mapM abstrTerm args + abstrTerm t = do + at :: LNTerm <- varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t) + return at + where getHint (viewTerm -> Lit (Var v)) = lvarName v + getHint _ = "z" makeRule (ps, cs, as) subst freshSubsts0 = - Rule (ProtoRuleACInfo ri (Disj freshSubsts)) prems concs acts + Rule (ProtoRuleACInfo ri (Disj freshSubsts) []) prems concs acts where prems = apply subst ps concs = apply subst cs acts = apply subst as diff --git a/src/Theory/Signature.hs b/src/Theory/Signature.hs --- a/src/Theory/Signature.hs +++ b/src/Theory/Signature.hs @@ -43,7 +43,7 @@ import Theory.Pretty import Theory.Fact -import Term.Maude.Types +import Term.Maude.Signature import Data.Binary @@ -76,7 +76,7 @@ -- | The empty pure signature. emptySignaturePure :: SignaturePure -emptySignaturePure = Signature S.empty emptyMaudeSig +emptySignaturePure = Signature S.empty minimalMaudeSig -- Instances ------------ diff --git a/src/Theory/Wellformedness.hs b/src/Theory/Wellformedness.hs --- a/src/Theory/Wellformedness.hs +++ b/src/Theory/Wellformedness.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | -- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt -- License : GPL v3 (see LICENSE) @@ -13,19 +14,33 @@ -- -- [protocol rules] -- --- 1. all facts are used with the same arity. +-- 1. no fresh names in rule. (protocol cond. 1) +-- ==> freshNamesReport -- --- 2. fr, in, and out, facts are used with arity 1. +-- 2. no Out or K facts in premises. (protocol cond. 2) +-- ==> factReports -- --- 3. fr facts are used with a variable of sort msg or sort fresh +-- 3. no Fr, In, or K facts in conclusions. (protocol cond. 3) +-- ==> factReports -- --- 5. fresh facts of the same rule contain different variables. [TODO] +-- 4. vars(rhs) subset of vars(lhs) u V_Pub +-- ==> multRestrictedReport -- --- 4. no fr, or in facts in conclusions. +-- 5. lhs does not contain reducible function symbols (*-restricted (a)) +-- ==> multRestrictedReport -- --- 5. no out facts in premises. +-- 6. rhs does not contain * (*-restricted (b)) +-- ==> multRestrictedReport -- --- 6. no protocol fact uses a reserved name => +-- 7. all facts are used with the same arity. +-- +-- 8. fr, in, and out, facts are used with arity 1. +-- +-- 9. fr facts are used with a variable of sort msg or sort fresh +-- +-- 10. fresh facts of the same rule contain different variables. [TODO] +-- +-- 11. no protocol fact uses a reserved name => -- [TODO] change parser to ensure this and pretty printer to show this. -- -- [security properties] @@ -57,9 +72,13 @@ import qualified Data.Set as S import Control.Basics import Control.Category +import Data.Traversable hiding (mapM) +import Control.Monad.Bind + +import Term.Maude.Signature import Extension.Prelude -import Text.Isar +import Text.PrettyPrint.Class import Theory ------------------------------------------------------------------------------ @@ -97,10 +116,14 @@ lowerCase :: String -> String lowerCase = map toLower --- | Pretty-print a comman, separated list of 'LVar's. +-- | Pretty-print a comma, separated list of 'LVar's. prettyVarList :: Document d => [LVar] -> d prettyVarList = fsep . punctuate comma . map prettyLVar +-- | Pretty-print a comma, separated list of 'LNTerms's. +prettyLNTermList :: Document d => [LNTerm] -> d +prettyLNTermList = fsep . punctuate comma . map prettyLNTerm + -- | Wrap strings at word boundaries. wrappedText :: Document d => String -> d wrappedText = fsep . map text . words @@ -210,9 +233,9 @@ do ruleFacts <$> get thyCache thy <|> do RuleItem ru <- get thyItems thy return $ ruleFacts ru - <|> do LemmaItem (Lemma name fmE _ _ _) <- get thyItems thy - return $ (,) ("lemma " ++ quote name) $ do - fa <- formulaFacts fmE + <|> do LemmaItem l <- get thyItems thy + return $ (,) ("lemma " ++ quote (get lName l)) $ do + fa <- formulaFacts (get lFormulaE l) return $ (text (show fa), factInfo fa) <|> do return $ (,) "unique_insts declaration" $ do tag <- S.toList $ get (sigpUniqueInsts . thySignature) thy @@ -276,7 +299,7 @@ ": " ++ showInfo info) $-$ nest 2 ppFa where - showInfo (tag, k, mult) = show $ (showFactTag tag, k, mult) + showInfo (tag, k, multipl) = show $ (showFactTag tag, k, multipl) theoryFacts' = [ (ru, fa) | (ru, fas) <- theoryFacts, fa <- fas ] factIdentifier (_, (_, (tag, _, _))) = map toLower $ showFactTag tag @@ -284,14 +307,15 @@ -- Check that every fact referenced in a formula is present as an action -- of a protocol rule. We have to add the linear "K/1" fact, as the -- WF-check cannot rely on a loaded intruder theory. - ruleActions = S.fromList $ ((factInfo (kLogFact undefined)) :) $ - do RuleItem ru <- get thyItems thy - factInfo <$> get rActs ru + ruleActions = S.fromList $ map factInfo $ + kLogFact undefined : dedLogFact undefined : + (do RuleItem ru <- get thyItems thy; get rActs ru) inexistentActions = do - LemmaItem (Lemma name fmE _ _ _) <- get thyItems thy - fa <- sortednub $ formulaFacts fmE + LemmaItem l <- get thyItems thy + fa <- sortednub $ formulaFacts (get lFormulaE l) let info = factInfo fa + name = get lName l if info `S.member` ruleActions then [] else return $ (,) "lemma actions" $ @@ -335,8 +359,9 @@ -- of facts, term, and atom constructors explicit. formulaReports :: OpenTheory -> WfErrorReport formulaReports thy = do - LemmaItem (Lemma name fmE _ _ _) <- get thyItems thy - let header = "lemma " ++ quote name + LemmaItem l <- get thyItems thy + let header = "lemma " ++ quote (get lName l) + fmE = get lFormulaE l msum [ ((,) "quantifier sorts") <$> checkQuantifiers header fmE , ((,) "formula terms") <$> checkTerms header fmE , ((,) "guardedness") <$> checkGuarded header fmE @@ -368,9 +393,9 @@ \ this is unambiguous" where offenders = filter (not . allowed) $ formulaTerms fm - allowed (Lit (Var (Bound _))) = True - allowed (Lit (Con (Name PubName _))) = True - allowed _ = False + allowed (viewTerm -> Lit (Var (Bound _))) = True + allowed (viewTerm -> Lit (Con (Name PubName _))) = True + allowed _ = False -- check that the formula can be converted to a guarded formula checkGuarded header fm = case fromFormulaNegate fm of @@ -410,6 +435,73 @@ thyProtoRules thy -} + +-- | Check that all rules are multipliation restricted. Compared +-- to the definition in the paper we are slightly more lenient. +-- We also accept a rule that is an instance of a multiplication +-- restricted rule. +-- 1. Consistently abstract terms with outermost reducible function symbols +-- occuring in lhs with fresh variables in rule. +-- 2. check vars(rhs) subset of vars(lhs) u V_Pub for abstracted rule for abstracted variables. +-- 3. check that * does not occur in rhs of abstracted rule. +multRestrictedReport :: OpenTheory -> WfErrorReport +multRestrictedReport thy = do + ru <- theoryRules thy + (,) "multiplication restriction of rules" <$> + case restrictedFailures ru of + ([],[]) -> [] + (mults, unbounds) -> + return $ + (text "The following rule is not multiplication restricted:") + $-$ (nest 2 (prettyProtoRuleE ru)) + $-$ (text "") + $-$ (text "After replacing reducible function symbols in lhs with variables:") + $-$ (nest 2 $ prettyProtoRuleE (abstractRule ru)) + $-$ (text "") + $-$ (if null mults then mempty + else nest 2 $ (text "Terms with multiplication: ") <-> (prettyLNTermList mults)) + $-$ (if null unbounds then mempty + else nest 2 $ (text "Variables that occur only in rhs: ") <-> (prettyVarList unbounds)) + where + abstractRule ru@(Rule i lhs acts rhs) = + (`evalFreshAvoiding` ru) . (`evalBindT` noBindings) $ do + Rule i <$> mapM (traverse abstractTerm) lhs + <*> mapM (traverse replaceAbstracted) acts + <*> mapM (traverse replaceAbstracted) rhs + + abstractTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible = + fAppNonAC o <$> mapM abstractTerm args + abstractTerm (viewTerm -> Lit l) = return $ lit l + abstractTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t "x" + + replaceAbstracted t = do + b <- lookupBinding t + case b of + Just v -> return $ varTerm v + Nothing -> + case viewTerm t of + FApp o args -> + fApp o <$> mapM replaceAbstracted args + Lit l -> return $ lit l + + restrictedFailures ru = (mults, unbound ruAbstr \\ unbound ru) + where + ruAbstr = abstractRule ru + + mults = [ mt | Fact _ ts <- get rConcs ru, t <- ts, mt <- multTerms t ] + + multTerms t@(viewTerm -> FApp (AC Mult) _) = [t] + multTerms (viewTerm -> FApp _ as) = concatMap multTerms as + multTerms _ = [] + + unbound ru = [v | v <- frees (get rConcs ru) \\ frees (get rPrems ru) + , lvarSort v /= LSortPub ] + + + irreducible = irreducibleFunctionSymbols $ get (sigpMaudeSig . thySignature) thy + + + -- | All 2-multicombinations of a list. -- multicombine2 :: [a] -> [(a,a)] -- multicombine2 xs0 = do (x,xs) <- zip xs0 $ tails xs0; (,) x <$> xs @@ -432,6 +524,7 @@ , factReports , formulaReports , uniqueInstsReport + , multRestrictedReport ] -- | Adds a note to the end of the theory, if it is not well-formed. diff --git a/src/Web/Dispatch.hs b/src/Web/Dispatch.hs --- a/src/Web/Dispatch.hs +++ b/src/Web/Dispatch.hs @@ -26,7 +26,7 @@ import Web.Settings import Yesod.Core -import Yesod.Helpers.Static +import Yesod.Static import Network.Wai import qualified Data.Map as M @@ -47,6 +47,7 @@ import System.Directory -- | Create YesodDispatch instance for the interface. +-- mkYesodDispatch "WebUI" resourcesWebUI mkYesodDispatch "WebUI" resourcesWebUI -- | Static route for favicon file. @@ -55,34 +56,36 @@ -- | Favicon handler function (favicon.ico). getFaviconR :: Handler () -getFaviconR = redirect RedirectPermanent (StaticR faviconRoute) +getFaviconR = redirect (StaticR faviconRoute) -- | Robots file handler function (robots.txt). getRobotsR :: Handler RepPlain getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: B.ByteString) -- | Initialization function for the web application. -withWebUI :: FilePath -- ^ Working directory. +withWebUI :: String -- ^ Message to output once the sever is ready. + -> FilePath -- ^ Working directory. -> Bool -- ^ Load last proof state if present -> Bool -- ^ Automatically save proof state -> (FilePath -> IO ClosedTheory) -- ^ Theory loader (from file). -> (String -> IO ClosedTheory) -- ^ Theory loader (from string). -> (OpenTheory -> IO ClosedTheory) -- ^ Theory closer. -> Bool -- ^ Show debugging messages? - -> Maybe FilePath -- ^ Path to static content directory + -> FilePath -- ^ Path to static content directory -> (Application -> IO b) -- ^ Function to execute -> IO b -withWebUI thDir loadState autosave thLoader thParser thCloser debug' stPath f = do +withWebUI readyMsg thDir loadState autosave thLoader thParser thCloser debug' stPath f = do thy <- getTheos thrVar <- newMVar M.empty thyVar <- newMVar thy + st <- static stPath when autosave $ createDirectoryIfMissing False autosaveDir (`E.finally` shutdownThreads thrVar) $ f =<< toWaiApp WebUI { workDir = thDir , parseThy = liftIO . thParser , closeThy = thCloser - , getStatic = static $ fromMaybe defaultStaticDir stPath + , getStatic = st , theoryVar = thyVar , threadVar = thrVar , autosaveProofstate = autosave @@ -104,7 +107,7 @@ _ -> return Nothing return $ M.fromList $ catMaybes thys - else loadTheories thDir thLoader + else loadTheories readyMsg thDir thLoader shutdownThreads thrVar = do m <- modifyMVar thrVar $ \m -> return (M.empty, m) @@ -115,13 +118,12 @@ -- | Load theories from the current directory, generate map. -loadTheories :: FilePath -> (FilePath -> IO ClosedTheory) -> IO TheoryMap -loadTheories thDir thLoader = do +loadTheories :: String -> FilePath -> (FilePath -> IO ClosedTheory) -> IO TheoryMap +loadTheories readyMsg thDir thLoader = do mkImageDir thPaths <- filter (".spthy" `isSuffixOf`) <$> getDirectoryContents thDir theories <- catMaybes <$> mapM loadThy (zip [1..] (map (thDir ) thPaths)) - putStrLn "" - putStrLn "Finished loading theories ... server ready." + putStrLn readyMsg return $ M.fromList theories where -- Create image directory diff --git a/src/Web/Hamlet.hs b/src/Web/Hamlet.hs --- a/src/Web/Hamlet.hs +++ b/src/Web/Hamlet.hs @@ -14,7 +14,10 @@ PatternGuards, FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Web.Hamlet where +module Web.Hamlet ( + rootTpl + , overviewTpl + ) where import Theory import Web.Types @@ -23,17 +26,19 @@ import Text.PrettyPrint.Html import Yesod.Core -import Yesod.Form -import Text.Hamlet +-- import Yesod.Form +-- import Text.Hamlet +import Control.Monad.IO.Class (liftIO) import Data.Ord import Data.List import Data.Time.Format import Data.Version (showVersion) import qualified Data.Map as M -import qualified Data.Text as T +-- import qualified Data.Text as T +import Text.Blaze.Html5 (preEscapedString) -import Control.Monad.RWS (runRWST) +-- import Control.Monad.RWS (runRWST) import qualified Control.Exception as E import System.Locale @@ -42,9 +47,9 @@ -- Quasi-quotation syntax changed from GHC 6 to 7, -- so we need this switch in order to support both #if __GLASGOW_HASKELL__ >= 700 -#define HAMLET hamlet +#define HAMLET whamlet #else -#define HAMLET $hamlet +#define HAMLET $whamlet #endif -- @@ -52,7 +57,7 @@ -- -- | Wrapper for @HtmlDoc@ values. -wrapHtmlDoc :: HamletValue h => HtmlDoc Doc -> h +wrapHtmlDoc :: HtmlDoc Doc -> Widget wrapHtmlDoc doc | null res = exceptionTpl err | otherwise = [HAMLET|#{preEscapedString res}|] @@ -61,10 +66,12 @@ err = "Trying to render document yielded empty string. This is a bug." -- | Run a ThHtml value, catch exceptions. -wrapThHtml :: HamletValue h => HtmlDoc Doc -> IO h -wrapThHtml th = E.catch (return $ wrapHtmlDoc th) handleEx +wrapThHtml :: HtmlDoc Doc -> IO Widget +wrapThHtml th = + E.catch (return $ wrapHtmlDoc th) handleEx where - handleEx :: HamletValue h => E.SomeException -> IO h + -- handleEx :: HamletValue h => E.SomeException -> IO h + handleEx :: E.SomeException -> IO Widget handleEx e = do putStrLn "----------------" putStrLn "Caught exception" @@ -77,49 +84,58 @@ -- -- | Exception/error template. -exceptionTpl :: HamletValue h => String -> h +exceptionTpl :: String -> Widget exceptionTpl err = [HAMLET|

Caught exception! \#{err} |] +{- -- | Simple template for serving sites which are loaded through -- AJAX instead of a normal request (no html/head/body tags). -- -- Note: Don't use ajaxLayout and defaultLayout together, use -- only one or the other. -ajaxLayout :: Monad m => GenericWidget m () -> GenericHandler m RepHtml -ajaxLayout w = do - (body, _, _) <- runRWST (unGWidget $ extractBody w) () 0 - hamletToRepHtml [HAMLET|^{body}|] +-- ajaxLayout :: Monad m => GenericWidget m () -> GenericHandler m RepHtml +ajaxLayout w = error "ajaxLayout" $ fmap fst $ unGWidget w -- do + -- (body, _, _) <- runRWST (unGWidget $ extractBody w) () 0 + -- (body, _, _) <- unGWidget $ w -- () 0 + -- hamletToRepHtml [HAMLET|^{body}|] +-} -- | Template for root/welcome page. -rootTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute, h ~ Widget ()) - => TheoryMap -- ^ Map of loaded theories - -> Widget () -- ^ Form widget (for loading new theories) - -> Enctype -- ^ Form encoding type (for form) - -> Html -- ^ Nonce field (for form) - -> h -rootTpl theories form enctype nonce = [HAMLET| +rootTpl :: TheoryMap -- ^ Map of loaded theories + -> Widget +-- rootTpl theories form enctype nonce = [whamlet| +rootTpl theories = [whamlet| +
+
+
+
+
+
+
+ Running + \ Tamarin + \ #{showVersion version} \^{introTpl} -

Currently loaded theories -

- \^{theoriesTpl theories} -

Loading a new theory -

- ^{form} -

- ^{addHtml nonce} - -

Note: You can save a theory by downloading the source. +

+

+ \^{theoriesTpl theories} +

Loading a new theory +

+ Filename: + +

+ +

Note: You can save a theory by downloading the source. |] -- | Template for listing theories. -theoriesTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => TheoryMap -> h -theoriesTpl thmap = [HAMLET| +theoriesTpl :: TheoryMap -> Widget +theoriesTpl thmap = [whamlet| $if M.null thmap No theories loaded! $else @@ -148,19 +164,17 @@ | otherwise = ntail i xs -- | Template for single line in table on root page. -theoryTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) - => (TheoryIdx, TheoryInfo) -> h +theoryTpl :: (TheoryIdx, TheoryInfo) -> Widget theoryTpl th = [HAMLET| - + \#{get thyName $ tiTheory $ snd th} - #{formatTime defaultTimeLocale "%T" $ tiTime $ snd th} $if tiPrimary (snd th) Original $else - Modified + Modified #{origin th} |] where @@ -170,7 +184,8 @@ Interactive -> "(interactively created)" -- | Template for listing threads. -threadsTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => [T.Text] -> h +-- threadsTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => [T.Text] -> h +{- threadsTpl threads = [HAMLET|

Threads

@@ -189,16 +204,16 @@ #{th} Kill |] +-} -- | Template for header frame (various information) -headerTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) - => TheoryInfo -- ^ Theory information - -> h +headerTpl :: TheoryInfo -> Widget headerTpl info = [HAMLET| -

- Running \ - tamarin prover - \ #{showVersion version} +
+
+ Running + \ Tamarin + \ #{showVersion version}
Index Download @@ -206,16 +221,17 @@
  • Actions
    • Show source -
    • Show variants -
    • Edit theory -
    • Add lemma
    • Options
      • Compact graphs
      • Compress sequents -
      • Debug pane |] where + --
      • Debug pane + --
      • Show variants + --
      • Edit theory + --
      • Add lemma + -- idx = tiIndex info filename = get thyName (tiTheory info) ++ ".spthy" @@ -229,24 +245,22 @@ -} -- | Template for proof state (tree) frame. -proofStateTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) - => TheoryInfo -- ^ Theory information - -> IO h -proofStateTpl = wrapThHtml . theoryIndex . tiTheory +proofStateTpl :: RenderUrl -> TheoryInfo -> IO Widget +proofStateTpl renderUrl ti = wrapThHtml $ theoryIndex renderUrl (tiIndex ti) (tiTheory ti) -- | Framing/UI-layout template (based on JavaScript/JQuery) -overviewTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) - => TheoryInfo -- ^ Theory information +overviewTpl :: RenderUrl + -> TheoryInfo -- ^ Theory information -> TheoryPath -- ^ Theory path to load into main - -> IO h -overviewTpl info path = do - proofState <- proofStateTpl info - mainView <- pathTpl info path + -> IO Widget +overviewTpl renderUrl info path = do + proofState <- proofStateTpl renderUrl info + mainView <- pathTpl renderUrl info path return [HAMLET|
        ^{headerTpl info}
        -

         Proof scripts +

        Proof scripts
        ^{proofState} @@ -255,84 +269,106 @@
        -

         Visualization display +

        Visualization display
        \^{mainView} |] -- | Theory path, displayed when loading main screen for first time. -pathTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) - => TheoryInfo -- ^ The theory +pathTpl :: RenderUrl + -> TheoryInfo -- ^ The theory -> TheoryPath -- ^ Path to display on load - -> IO h -pathTpl info TheoryMain = return [HAMLET| -

        Welcome!


        + -> IO Widget +pathTpl _ info TheoryHelp = return [whamlet|

        Theory information

          Theory: #{get thyName $ tiTheory info}
        • Loaded at #{formatTime defaultTimeLocale "%T" $ tiTime info}
        • Origin: #{show $ tiOrigin info} -

          Quick introduction

          -

          - Left pane: Proof scripts display. You \ - can select proof states and examine them further \ - by clicking on them! -

          - Center pane: Visualization and \ - information display relating to the currently \ - selected item. -

          - Keyboard shortcuts: The interactive interface supports \ - multiple keyboard shortcuts for convenience. -

            -
          • - Keys j and k: Jump to the next/previous \ - proof path within the currently focused lemma. -
          • - Keys J and K: Jump to the next/previous \ - open goal within the currently focused lemma, or to the \ - next/previous lemma if there are no more open goals in the current \ - lemma. -
          • - Keys 1 to 9: Apply the proof method with \ - the given number as shown in the applicable proof method section \ - in the main view. +
            +

            Quick introduction

            +