diff --git a/.ghci b/.ghci --- a/.ghci +++ b/.ghci @@ -1,5 +1,6 @@ :set -iinteractive-only-src -- :set -ilib/term/src -- :set -ilib/utils/src +:set -ilib/theory/src :set -isrc :set -Wall -fwarn-tabs diff --git a/data/AUTHORS b/data/AUTHORS --- a/data/AUTHORS +++ b/data/AUTHORS @@ -1,7 +1,8 @@ Authors: Benedikt Schmidt - Simon Meier + Simon Meier Contributors: protocol models, GUI: Cas Cremers original web interface: Cedric Staub diff --git a/data/CHANGES b/data/CHANGES --- a/data/CHANGES +++ b/data/CHANGES @@ -1,3 +1,41 @@ +* 0.8.2.0 + documentation: + - The submitted draft of the Meier's PhD thesis on "Advancing Automated + Security Protocol Analysis" is now available online at + + http://www.infsec.ethz.ch/research/software/tamarin + + It explains the theory underlying Tamarin in much more detail than our + CSF'12 paper. It also explains the theory underlying trace induction + and type assertions. + + user interface: + - allow lemma selection with '--prove': The lemmas being analyzed are the + ones whose name is an extension of one of the prefixes given with a + '--prove' flag. + - disallow parsing of reserved rule names: + Fresh, irecv, isend, coerce, fresh, pub + + new protocol models (referenced in Meier's PhD thesis): + - models of TESLA Scheme 1 and 2 + - modeled the + - injective agreement for TLS and NSLPK + + - include the contributed YubiKey models from: + "R. Kuennemann and G. Steel. Yubisecure? formal security analysis + results for the Yubikey and YubiHSM. In Proc. of the 8th Workshop on + Security and Trust Management (STM 2012), Pisa, Italy, September 2012." + + - minimal hash chain example: this demonstrates a short-coming in our + current proof calculus. It does not suffice to reason about iterated + function application. + + architectural changes: + - upgraded the GUI to use version 1.1 of the Yesod web-framework + - split off Theory module hierarchy as a separate library called + 'tamarin-prover-theory' + + * 0.8.1.0 - enabled parallelization by default when compiling `tamarin-prover` with GHC 7.4 and higher. It uses as many threads as there are CPU cores on diff --git a/data/doc/MANUAL b/data/doc/MANUAL --- a/data/doc/MANUAL +++ b/data/doc/MANUAL @@ -1,7 +1,7 @@ User manual for the Tamarin prover ================================== -Date: 2012/06/04 +Date: 2012/09/28 Authors: Simon Meier , Benedikt Schmidt @@ -140,122 +140,26 @@ Additional Theory ================= -Most of the theory behind the Tamarin prover is described in our CSF 2012 -paper, whose extended version is available from +Most of the theory underlying the Tamarin prover is described in the submitted +draft of Meier's PhD thesis available from http://www.infsec.ethz.ch/research/software/tamarin -The implementation exploits a slightly more restricted definition of normal -dependency graphs and adapted versions of the constraint solving rules that -also allow security properties to refer to the conclusions of normal -construction rules. A technical report documenting this version of the -constraint solver is under preparation. From a usage perspective, the changes -are minor and explained below in the sections on -`Induction` and `Typing Invariants over the Extended Traces`. - -Moreover, we added a constraint solving rule that allows to reason about -protocols that make use of exclusive access to linear facts. A typical example -is 'loops/Minimal_Create_Use_Destroy.spthy'. The corresponding constraint -reduction rule is explained below. - -Apart from the above changes to the constraint solving rules, we also refined -the theory in two ways that allow to share work between different constraint -reduction steps. First, we store multiple constraint reduction steps in the -form of *precomputed case distinctions*. Second, we delay the enumeration of -the finite variants of multiset rewriting rules using an *equation store*. We -explain both of these refinements below. - - -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. - - -Inductive Strengthening ------------------------ - -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. For some protocols, we must however strengthen security properties -before being able to prove them using our backwards reasoning technique. This -strengthening works by transforming the security property according to the -induction scheme associated with the set of traces of a protocol. Intuitively, -this strengthening amounts to searching for traces that violate the security -property, but do not contain any prefix that violates the security property. -Stated differently, we focus on first violations of security properties with -respect to the prefix-order on traces. - -Properties that should be proven using induction can be marked with the -attribute [use_induction]. In the interactive GUI, one can just select -`induction` as a proof method provided the constraint system contains just one -guarded trace property. - -For examples of protocols where inductive strengthening is required for a -successful proof, see the directories `examples/loops` and -`examples/related_work`. - - -Typing Invariants over the Extended Traces ------------------------------------------- - -Note that every protocol communicating via the public network/adversary -implicitly contains loops. The adversary may send messages received from a -later step of one instance a role to an earlier step of another instance of -the same role. These loops manifest themselves during backwards reasoning as -infinite proof branches. For trivial loops where all messages are also -received as plain-text, we can prune these branches using the constraint -reduction rule N6. To prune more complicated loops, e.g., loops stemming from -receiving an encrypted message and sending out some of its contents, we need -so called typing invariants. - -A typing invariant specifies the possible instantiations of a message variable -sent to the adversary. We describe these instantiations by relating an action -logging the instantiation in the rule sending the variable to actions logging -the possible instantiations in the rules sending the contents of this -variable. See the 'classic/NSLPK3.spthy' file for an example of a typing -invariant. - -To enable the specification of the case that the intruder constructed the -message that a variable is instantiated with, we changed every construction -rule such that a KU-action logs the rule's conclusion. Properties referring to -this KU-actions can only be evaluated over the traces of normal dependency -graphs of a protocol. We call these traces the 'extended traces of a protocol'. -Note that we cannot transfer the validity of properties over extended traces -to the validity of these properties over standard traces stemming from the -multiset rewriting semantics. However, we can use these properties over -extended traces as lemmas during the proof of a property over standard traces -using the lemma attribute [reuse] or [typing]. - -The goal of typing invariants is to ensure that all chain-constraints are -solved during the precomputation of the case distinctions. We use a two-step -process to achieve this. We first precompute the so-called *untyped case -distinctions* without the assumption of the validity of any typing invariant. -These untyped precomputed case are used during the proof of a typing -invariant. We then use the typing invariants to refine the untyped case -distinctions to typed case distinctions. They are used during the proofs of -properties other than typing invariants. +Some of the missing pieces will be described in Schmidt's PhD thesis. His +thesis explains the notion of an equation store and design of the normal form +message deduction rules used to reason about Diffie-Hellman explanation, +bilinear pairings, and multiset union. Note that this version of Tamarin does +not yet support bilinear pairings and multiset union. It does support +Diffie-Hellman exponentiation as described in our CSF'12 paper, +and it uses equation stores as explained below. -In the input file, all typing invariants are marked with the [typing] -attribute. In the GUI, you can inspect both the untyped and typed precomputed -case distinctions. A typing invariant achieves its goal, if the typed -precomputed case distinctions are marked with "all chains solved". +Our preliminary support for reasoning about protocols that make use of +exclusive access to linear facts is not yet described as part of a research +paper. It is explained in the following subsection. Reasoning about Exclusivity: Facts Symbols with Injective Instances ------------------------------------------------------------ +------------------------------------------------------------------- We say that a fact symbol 'f' has *injective instances* with respect to a multiset rewriting system 'R', if there is no reachable state of @@ -354,8 +258,8 @@ 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 +The formal definition of security protocol theories is given in Meier's thesis +available from http://www.infsec.ethz.ch/research/software/tamarin diff --git a/data/examples/Tutorial.spthy b/data/examples/Tutorial.spthy --- a/data/examples/Tutorial.spthy +++ b/data/examples/Tutorial.spthy @@ -3,15 +3,14 @@ ============================================================== Authors: Simon Meier, Benedikt Schmidt -Date: April 2012 +Date: September 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 +This user guide assumes that you have a copy of the submitted draft of Meier's +PhD thesis, which is available from http://www.infsec.ethz.ch/research/software/tamarin. The input files for the Tamarin prover have the extension .spthy, which is @@ -20,8 +19,8 @@ 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. + 3. the guarded trace properties whose satisfiability or 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. @@ -332,6 +331,31 @@ " /* +Note that we can also strengthen the authentication property to a version of +injective authentication. Our formulation is stronger than the standard +formulation of injective authentication, as it is based on uniqueness instead +of counting. For most protocols, that guarantee injective authentication one +can also prove such a uniqueness claim, as they agree on appropriate fresh +data. +*/ + +lemma Client_auth_injective: + " /* 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 + /* and there is no other client that had the same request */ + & (All #j. SessKeyC(S, k) @ #j ==> #i = #j) + ) + /* 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 @@ -382,16 +406,16 @@ 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 +By now, you should have enough knowledge to understand the case studies +included with Tamarin. 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 +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 + Simon Meier iridcode@gmail.com Cas Cremers cas.cremers@inf.ethz.ch diff --git a/data/examples/classic/NSLPK3.spthy b/data/examples/classic/NSLPK3.spthy --- a/data/examples/classic/NSLPK3.spthy +++ b/data/examples/classic/NSLPK3.spthy @@ -60,6 +60,7 @@ ] --[ IN_R_1_ni( ni, m1 ) , OUT_R_1( m2 ) + , Running(I, $R, <'init',ni,~nr>) ]-> [ Out( m2 ) , St_R_1($R, I, ni, ~nr) @@ -75,6 +76,9 @@ , !Pk(R, pkR) ] --[ IN_I_2_nr( nr, m2) + , Commit (I, R, <'init',ni,nr>) // need to log identities explicitely to + , Running(R, I, <'resp',ni,nr>) // specify that they must not be + // compromised in the property. ]-> [ Out( m3 ) , Secret(I,R,nr) @@ -86,7 +90,8 @@ , !Ltk(R, ltkR) , In( aenc{'3', nr}pk(ltkR) ) ] - --[]-> + --[ Commit (R, I, <'resp',ni,nr>) + ]-> [ Secret(R,I,nr) , Secret(R,I,ni) ] @@ -141,6 +146,23 @@ & not (Ex #r. RevLtk(B) @ r) )" +// Injective agreement from the perspective of both the initiator and the responder. +lemma injective_agree: + " /* Whenever somebody commits to running a session, then*/ + All actor peer params #i. + Commit(actor, peer, params) @ i + ==> + /* there is somebody running a session with the same parameters */ + (Ex #j. Running(actor, peer, params) @ j & j < i + /* and there is no other commit on the same parameters */ + & not(Ex actor2 peer2 #i2. + Commit(actor2, peer2, params) @ i2 & not(#i = #i2) + ) + ) + /* or the adversary perform a long-term key reveal on actor or peer */ + | (Ex #r. RevLtk(actor) @ r) + | (Ex #r. RevLtk(peer) @ r) + " // Consistency check: ensure that secrets can be shared between honest agents. lemma session_key_setup_possible: diff --git a/data/examples/classic/NSPK3.spthy b/data/examples/classic/NSPK3.spthy new file mode 100644 --- /dev/null +++ b/data/examples/classic/NSPK3.spthy @@ -0,0 +1,177 @@ +theory NSLPK3 +begin + +builtins: asymmetric-encryption + +/* + Protocol: The classic three message version of the + flawed Needham-Schroeder Public Key Protocol + Modeler: Simon Meier + Date: September 2012 + + Source: Gavin Lowe. Breaking and fixing the Needham-Schroeder + public-key protocol using FDR. In Tiziana Margaria and + Bernhard Steffen, editors, TACAS, volume 1055 of Lecture Notes + in Computer Science, pages 147–166. Springer, 1996. + + Status: working + + Note that we are using explicit global constants for discerning the + different encryption instead of the implicit typing. + */ + + +// 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 protocol + + protocol NSPK3 { + 1. I -> R: {'1',ni,I}pk(R) + 2. I <- R: {'2',ni,nr}pk(I) + 3. I -> R: {'3',nr}pk(R) + } +*/ + +rule I_1: + let m1 = aenc{'1', ~ni, $I}pkR + in + [ Fr(~ni) + , !Pk($R, pkR) + ] + --[ OUT_I_1(m1) + ]-> + [ Out( m1 ) + , St_I_1($I, $R, ~ni) + ] + +rule R_1: + let m1 = aenc{'1', ni, I}pk(ltkR) + m2 = aenc{'2', ni, ~nr}pkI + in + [ !Ltk($R, ltkR) + , In( m1 ) + , !Pk(I, pkI) + , Fr(~nr) + ] + --[ IN_R_1_ni( ni, m1 ) + , OUT_R_1( m2 ) + , Running(I, $R, <'init',ni,~nr>) + ]-> + [ Out( m2 ) + , St_R_1($R, I, ni, ~nr) + ] + +rule I_2: + let m2 = aenc{'2', ni, nr}pk(ltkI) + m3 = aenc{'3', nr}pkR + in + [ St_I_1(I, R, ni) + , !Ltk(I, ltkI) + , In( m2 ) + , !Pk(R, pkR) + ] + --[ IN_I_2_nr( nr, m2) + , Commit (I, R, <'init',ni,nr>) // need to log identities explicitely to + , Running(R, I, <'resp',ni,nr>) // specify that they must not be + // compromised in the property. + ]-> + [ Out( m3 ) + , Secret(I,R,nr) + , Secret(I,R,ni) + ] + +rule R_2: + [ St_R_1(R, I, ni, nr) + , !Ltk(R, ltkR) + , In( aenc{'3', nr}pk(ltkR) ) + ] + --[ Commit (R, I, <'resp',ni,nr>) + ]-> + [ Secret(R,I,nr) + , Secret(R,I,ni) + ] + +/* TODO: Also model session-key reveals and adapt security properties. */ +rule Secrecy_claim: + [ Secret(A, B, m) ] --[ Secret(A, B, m) ]-> [] + + + +/* Note that we are using an untyped protocol model. For proofs, we therefore +require a protocol specific type invariant for proof construction. In +principle, such an invariant is not required for attack search, but does help +a lot. + +See 'NSLPK3.spthy' for a detailed explanation of the construction of this +invariant. +*/ +lemma types [typing]: + " (All ni m1 #i. + IN_R_1_ni( ni, m1) @ i + ==> + ( (Ex #j. KU(ni) @ j & j < i) + | (Ex #j. OUT_I_1( m1 ) @ j) + ) + ) + & (All nr m2 #i. + IN_I_2_nr( nr, m2) @ i + ==> + ( (Ex #j. KU(nr) @ j & j < i) + | (Ex #j. OUT_R_1( m2 ) @ j) + ) + ) + " + +// Nonce secrecy from the perspective of both the initiator and the responder. +lemma nonce_secrecy: + " /* It cannot be that */ + not( + Ex A B s #i. + /* somebody claims to have setup a shared secret, */ + Secret(A, B, s) @ i + /* but the adversary knows it */ + & (Ex #j. K(s) @ j) + /* without having performed a long-term key reveal. */ + & not (Ex #r. RevLtk(A) @ r) + & not (Ex #r. RevLtk(B) @ r) + )" + +// Injective agreement from the perspective of both the initiator and the responder. +lemma injective_agree: + " /* Whenever somebody commits to running a session, then*/ + All actor peer params #i. + Commit(actor, peer, params) @ i + ==> + /* there is somebody running a session with the same parameters */ + (Ex #j. Running(actor, peer, params) @ j & j < i + /* and there is no other commit on the same parameters */ + & not(Ex actor2 peer2 #i2. + Commit(actor2, peer2, params) @ i2 & not(#i = #i2) + ) + ) + /* or the adversary perform a long-term key reveal on actor or peer */ + | (Ex #r. RevLtk(actor) @ r) + | (Ex #r. RevLtk(peer) @ r) + " + +// Consistency check: ensure that secrets can be shared between honest agents. +lemma session_key_setup_possible: + exists-trace + " /* It is possible that */ + Ex A B s #i. + /* somebody claims to have setup a shared secret, */ + Secret(A, B, s) @ i + /* without the adversary having performed a long-term key reveal. */ + & not (Ex #r. RevLtk(A) @ r) + & not (Ex #r. RevLtk(B) @ r) + " + +end diff --git a/data/examples/classic/TLS_Handshake.spthy b/data/examples/classic/TLS_Handshake.spthy --- a/data/examples/classic/TLS_Handshake.spthy +++ b/data/examples/classic/TLS_Handshake.spthy @@ -87,6 +87,7 @@ let MS = PRF(~pms, nc, ns) Ckey = h('clientKey', nc, ns, MS) + Skey = h('serverKey', nc, ns, MS) in [ St_C_1(C, nc, sid, pc) , In( @@ -96,7 +97,8 @@ , !Pk(S, pkS) , !Ltk(C, ltkC) ] - --[]-> + --[ Running(S, C, <'server', MS, Skey, Ckey>) + ]-> [ Out( < aenc{ '31', ~pms }pkS , sign{ '32', h('32', ns, S, ~pms) }ltkC @@ -125,6 +127,8 @@ /* 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 ) + , Running(C, S, <'client', MS, Skey, Ckey>) + , Commit(S, C, <'server', MS, Skey, Ckey>) ]-> [ Out( senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey @@ -140,23 +144,23 @@ [ 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 ) ]-> + --[ Commit(C, S, <'client', MS, Skey, Ckey>) + , SessionKeys( S, C, Skey, Ckey ) + ]-> [] /* TODO: Also model session-key reveals and adapt security properties. */ +axiom Eq_check_succeed: "All x y #i. Eq(x,y) @ i ==> x = y" + /* Session key secrecy from the perspective 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 */ + /* It cannot be that */ + "not( Ex S C keyS keyC #k. /* somebody claims to have setup session keys, */ SessionKeys(S, C, keyS, keyC) @ k @@ -167,7 +171,25 @@ /* without having performed a long-term key reveal. */ & not (Ex #r. RevLtk(S) @ r) & not (Ex #r. RevLtk(C) @ r) - ) )" + )" + +// Injective agreement from the perspective of both the initiator and the responder. +lemma injective_agree: + " /* Whenever somebody commits to running a session, then*/ + All actor peer params #i. + Commit(actor, peer, params) @ i + ==> + /* there is somebody running a session with the same parameters */ + (Ex #j. Running(actor, peer, params) @ j & j < i + /* and there is no other commit on the same parameters */ + & not(Ex actor2 peer2 #i2. + Commit(actor2, peer2, params) @ i2 & not(#i = #i2) + ) + ) + /* or the adversary perform a long-term key reveal on actor or peer */ + | (Ex #r. RevLtk(actor) @ r) + | (Ex #r. RevLtk(peer) @ r) + " /* Consistency check: ensure that session-keys can be setup between honest * agents. */ 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 @@ -5,10 +5,11 @@ Protocol: Example Modeler: Simon Meier, Benedikt Schmidt Date: January 2012 - + Status: working - - This is the artificial protocol from our CSF'12 paper, which we use to + + This is the example protocol P_{Ex2} in Simon Meier's PhD thesis. + It is also the artificial protocol from our CSF'12 paper, which we use to illustrate constraint solving and characterization. Note that, for characerization, you have to call the tamarin-prover as follows. @@ -43,23 +44,25 @@ builtins: symmetric-encryption rule Step1: - [ Fr(~x), Fr(~k) ] - --> - [ St(~x, ~k), Out(senc{~x}~k), Key(~k) ] + [ Fr(x), Fr(k) ] --> [ St(x, k), Out(senc(x,k)), Key(k) ] rule Step2: - [ St(x, k), In() ] - --[ Fin(x, k) ]-> - [ ] + [ St(x, k), In(x) ] --[ Fin(x, k) ]-> [ ] rule Reveal_key: - [ Key(k) ] - --[ Rev(k) ]-> - [ Out(k) ] + [ Key(k) ] --[ Rev(k) ]-> [ Out(k) ] // We search for trace-existence, as we want to characterize the possible // traces satisfying the given formula. lemma Characterize_Fin: - exists-trace "Ex k S #i. Fin(S, k) @ i" + exists-trace + "Ex k S #i. Fin(S, k) @ i" + +lemma Fin_unique: + "All S k #i #j. Fin(S, k) @ i & Fin(S, k) @ j ==> #i = #j" + +lemma Keys_must_be_revealed: + "All k S #i. Fin(S, k) @ i ==> Ex #j. Rev(k) @ j & j < i" + end diff --git a/data/examples/loops/Minimal_HashChain.spthy b/data/examples/loops/Minimal_HashChain.spthy new file mode 100644 --- /dev/null +++ b/data/examples/loops/Minimal_HashChain.spthy @@ -0,0 +1,123 @@ +theory Minimal_HashChain begin + +/* + Protocol: A minimal HashChain example (inspired by TESLA 2) + Modeler: Simon Meier + Date: August 2012 + + Status: note yet working + (requires multiset or repeated exponentiation reasoning) + + This models the key difficulty in the proof of the TESLA 2 protocol with + re-authentication: the verification that the key checking process is + sufficient to guarantee that the key is a key of the hash-chain. +*/ + +functions: f/1 + +// Chain setup phase +//////////////////// + +// Hash chain generation +rule Gen_Start: + [ Fr(seed) ] --> [ Gen(seed, seed), Out(seed) ] + +// The NextKey-facts are used by the sender rules to store the link between +// the keys in the chain. +rule Gen_Step: + [ Gen(seed, chain) ] + --[ ChainKey(chain) + ]-> + [ Gen(seed, f(chain) ) ] + +// At some point the sender decides to stop the hash-chain precomputation. +rule Gen_Stop: + [ Gen(seed, kZero) ] + --[ ChainKey(kZero) ]-> + [ !Final(kZero) ] + +// Key checking +/////////////// + +// Start checking an arbitrary key. Use a loop-id to allow connecting +// different statements about the same loop. +rule Check0: + [ In(kOrig) + , Fr(loopId) + ] + --[ Start(loopId, kOrig) + ]-> + [ Loop(loopId, kOrig, kOrig) ] + +rule Check: + [ Loop(loopId, k, kOrig) ] + --[ Loop(loopId, k, kOrig) ]-> + [ Loop(loopId, f(k), kOrig) ] + +rule Success: + [ Loop(loopId, kZero, kOrig), !Final(kZero) ] + --[ Success(loopId, kOrig) + ]-> [] + + +// Provable: restricts the search space +lemma Loop_Start [use_induction, reuse]: + "All lid k kOrig #i. Loop(lid, k, kOrig) @ i ==> + Ex #j. Start(lid, kOrig) @ j & j < i" + +// Provable: restricts the search space +lemma Loop_Success_ord [use_induction, reuse]: + "All lid k kOrig1 kOrig2 #i #j. + Loop(lid, k, kOrig1) @ i + & Success(lid, kOrig2) @ j + ==> + ( i < j) + " + +// Provable: connects an arbitrary loop step with its start. +lemma Loop_charn [use_induction]: + "All lid k kOrig #i. Loop(lid, k, kOrig) @ i ==> + Ex #j. Loop(lid, kOrig, kOrig) @ j" + +// Not yet provable: the problem is that we cannot express the relation +// between the keys on two different segments of the same loop. +// @BS: Do you have an idea on how we could use multisets to formulate a +// strong enough invariant? +lemma Loop_and_success [use_induction]: + "All lid k kOrig1 kOrig2 #i #j. + Loop(lid, k, kOrig1) @ i + & Success(lid, kOrig2) @ j + ==> + (Ex #j. ChainKey(k) @ j) + " + +// The ultimate goal! A successful check implies that the starting key is a +// key of the chain. +lemma Success_charn: + "All lid k #i. Success(lid, k) @ i ==> + Ex #j. ChainKey(k) @ j" + + + +/* A try on building the required 'smaller' relation in an axiomatic fashion. + This interacts too strongly with + + Does not really work! We need a better way to express this stuff. + +rule Succ_to_Smaller: + [ !Succ(x, y) ] --[ IsSmaller(x, y) ]-> [!Smaller(x, y)] + +rule Smaller_Extend: + [ !Succ(x, y), !Smaller(y, z) ] + --[ IsSmaller(x, z) ]-> + [ !Smaller(x, z) ] + +axiom force_succ_smaller: + "All #t1 2 a b c. IsSucc(a,b)@t1 + ==> Ex #t2 . IsSmaller(a,b)@t2 " + +axiom transitivity: + "All #t1 #t2 a b c. IsSmaller(a,b)@t1 & IsSmaller(b,c)@t2 + ==> Ex #t3 . IsSmaller(a,c)@t3 " +*/ +end diff --git a/data/examples/loops/TESLA_Scheme1.spthy b/data/examples/loops/TESLA_Scheme1.spthy --- a/data/examples/loops/TESLA_Scheme1.spthy +++ b/data/examples/loops/TESLA_Scheme1.spthy @@ -82,29 +82,30 @@ // the signature on this commitment. We use the receiver nonce to identify // receivers. rule Receiver0a: - [ Fr( ~rid ) ] + [ Fr( ~nR ) ] --> - [ Out( < $R, $S, ~rid > ) - , Receiver0b( ~rid, $R, $S ) ] + [ Out( < $R, $S, ~nR > ) + , Receiver0b( ~nR, $R, $S ) ] rule Receiver0b: - [ Receiver0b ( rid, R, S ) + [ Receiver0b ( nR, R, S ) , !Pk( S, pkS) , In( ) + , Fr(~rid) // Fresh name used to identify this receiver thread ] - --> - [ Receiver0b_check( rid, S, commit_k1 - , verify(signature, , pkS)) ] + --[ Setup(~rid) ]-> + [ Receiver0b_check( ~rid, S, commit_k1 + , verify(signature, , pkS)) ] rule Receiver0b_check: - [ Receiver0b_check(rid, S, commit_k1, true) ] + [ Receiver0b_check(nR, S, commit_k1, true), Fr(~rid) ] --> - [ Receiver1( rid, S, commit_k1 ) ] + [ Receiver1( nR, S, commit_k1 ) ] // Authenticated broadcasting rule Send1: - let data1 = <'1', ~m1, f(~k2)> + let data1 = <~m1, f(~k2)> in [ Sender1(S, ~k1) , Fr(~m1) @@ -117,7 +118,7 @@ ] rule Recv1: - let data1 = <'1', m1, commit_k2> + let data1 = in [ Receiver1(rid, S, commit_k1) , In( ) @@ -127,7 +128,7 @@ [ Receiver(rid, S, data1, mac1, commit_k1, commit_k2) ] rule SendN: - let data = <'N', ~m, f(~kNew), ~kOld> + let data = <~m, f(~kNew), ~kOld> in [ Sender(S, ~kOld, ~k) , Fr(~m) @@ -141,7 +142,7 @@ ] rule RecvN: - let data = <'N', m, commit_kNew, kOld> + let data = in [ In(< data, mac >) , Receiver(rid, S, dataOld, MAC{dataOld}kOld, f(kOld), commit_k) @@ -162,8 +163,9 @@ "(All rid S m #i. FromSender(rid, S, m) @ i ==> /* the server actually sent that data */ ( (Ex #j. Sent(S, m) @ j & j < i) - /* or the server's longterm key was compromised before the claim */ - | (Ex #j. RevealLtk(S) @ j & j < i) + /* or the server's longterm key was compromised before the receiver's + setup was complete */ + | (Ex #s #j. Setup(rid) @ s & RevealLtk(S) @ j & j < s) /* or one of the receivers expiredness assumptions before the claim was not met. */ | (Ex commit #ne #e. AssumeCommitNotExpired(rid, commit) @ ne diff --git a/data/examples/loops/TESLA_Scheme2.spthy b/data/examples/loops/TESLA_Scheme2.spthy new file mode 100644 --- /dev/null +++ b/data/examples/loops/TESLA_Scheme2.spthy @@ -0,0 +1,216 @@ +theory TESLA_Scheme2 begin + +/* + Protocol: The TESLA protocol, scheme 2 + Modeler: Simon Meier + Date: September 2012 + + Status: not yet working + + (We have trouble reasoning about the authenticity check. More + precisely, we cannot prove that a successful check implies that + the key is a key of the hash-chain. See Minimal_HashChain.spthy + for an example of the core problem.) + + Original descrption in [1]. This model is based on the following description + from [2]. + + Msg 0a. R -> S : nR + Msg 0b. S -> R : {k0 , nR }SK (S ) + Msg 1. S -> R : m1 , MAC (k1 , m1 ). + + And for n > 1: + Msg n. S -> R : Dn , MAC (kn , Dn ) where Dn = mn , kn-1 . + + One aim of this second version is to be able to tolerate an arbitrary number of + packet losses, and to drop unauthenticated packets, yet continue to authenticate + later packets. + + We verify that the use of cryptography is correct under the assumption that + the security condition holds. We do not verify that the timing schedule + works, as we do not have a notion of time. For a manual, but machine-checked + verification of the Scheme 2 of the TESLA protocol with time see [3]. + + + [1] Perrig, Adrian, Ran Canetti, Dawn Song, and Doug Tygar. "The TESLA + Broadcast Authentication Protocol." In RSA Cryptobytes, Summer 2002. + + [2] Philippa J. Hopcroft, Gavin Lowe: Analysing a stream authentication + protocol using model checking. Int. J. Inf. Sec. 3(1): 2-13 (2004) + + [3] David A. Basin, Srdjan Capkun, Patrick Schaller, Benedikt Schmidt: + Formal Reasoning about Physical Properties of Security Protocols. ACM Trans. + Inf. Syst. Secur. 14(2): 16 (2011) + +*/ + +builtins: signing + +functions: MAC/2, f/1 + +// PKI +////// + +rule Generate_Keypair: + [ Fr(~ltk) ] + --> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ] + +// We assume an active adversary. +// rule Reveal_Ltk: +// [ !Ltk(A, ltk) ] +// --[ RevealLtk(A) ]-> +// [ Out(ltk) ] + + +// Chain setup phase +//////////////////// + +// Hash chain generation +rule Gen_Start: + [ Fr(~seed) ] --> [ Gen(~seed, ~seed) ] + +// The NextKey-facts are used by the sender rules to store the link between +// the keys in the chain. +rule Gen_Step: + [ Gen(seed, chain) ] + --[ ChainKey(f(chain)) + ]-> + [ Gen(seed, f(chain) ) , NextKey( f(chain) , chain ) ] + +// At some point the sender decides to stop the hash-chain precomputation. +rule Gen_Stop: + [ Gen(seed, kZero) ] + --[ Expired(kZero), KeyZero(seed, kZero) ]-> + [ Sender(kZero) , !Sender0($S, kZero) ] + +// Intial chain key distribution +//////////////////////////////// + +// Everybody can listen in by sending a request for k_0. +rule Sender0: + let msgZero = + in + [ !Sender0(S, kZero), !Ltk(S, ltkS), In(nR) ] + --> + [ Out( ) ] + +// Receivers start by requesting key k_0 adn verifying the signature on this +// response. +rule Receiver0a: + [ Fr(~nR) ] --> [ Receiver0b($S, ~nR), Out(<$S, ~nR>) ] + +rule Receiver0b: + let msgZero = + in + [ Receiver0b(S,nR), !Pk(S, pkS), In() ] + --[ Eq( verify(signature, msgZero, pkS), true() ) ]-> + [ !Receiver(S, kZero) ] + +// Sending +////////// + +// We use the convention that k_{n-1} is denoted as kNp, where the 'p' stands +// for predecessor. +rule Sender: + let msgN = + in + [ Sender( kNp ), NextKey( kNp, kN), Fr(mN) ] + --[ Expired( kNp ) + , Sent( msgN ) + ]-> + [ Sender( kN ), Out(kNp), Out(msgN) ] + +// Receiving +//////////// + +rule Receiver: + let msg = + in + [ !Receiver(S, kZero), In( msg ) + , Fr(expiryCheck) + ] + --[ NotExpiredHere( expiryCheck ) ]-> + [ CheckAuth(expiryCheck, S, kZero, msg ) ] + +rule CheckAuth0: + let args = + in + [ CheckAuth(expiryCheck, S, kZero, msg) + , In(k) + , Fr(loopId) + ] + --[ CheckStart(loopId, args) + ]-> + [ CheckAuthLoop(loopId, k, args) ] + +rule CheckAuth: + [ CheckAuthLoop(loopId, k, args) ] + --[ CheckLoop( loopId, f(k), args ) + ]-> + [ CheckAuthLoop(loopId, f(k), args) ] + + +rule CheckAuthClaim: + let msg = + in + [ CheckAuthLoop(loopId, kZero, ) ] + --[ FromSender(msg, S, kRef, expiryCheck) + , Success(loopId) + ]-> [] + + +// Axioms; i.e., universal restrictions on the traces of interest +///////////////////////////////////////////////////////////////// + +axiom Eq_checks_succeed: "(All x y #j. Eq(x, y) @ j ==> x = y)" + +axiom Neq_checks_succeed: "(All x #j. Neq(x, x) @ j ==> F)" + +// The security condition of TESLA guarantees that +axiom Security_condition: + "All m S k check #i #j #e. + FromSender(m, S, k, check) @ i + & NotExpiredHere(check) @ j + & Expired(k) @ e + ==> + j < e" + + +// Security properties +////////////////////// + +// The following two lemmas constraint the search space strongly enough to +// allow reasoning about the authenticity of the received messages. + +lemma chain_keys_unique [use_induction, reuse]: + "All k #i #j. ChainKey(k) @ i & ChainKey(k) @ j ==> #i = #j" + +lemma knows_only_expired_chain_keys [use_induction, reuse]: + "All k #i #j. ChainKey(k) @i & KU(k) @ j ==> + (Ex #e. Expired(k) @ e & e < j)" + +// The current proof idea is to assume this axiom because we cannot yet prove +// it. Proving it requires support for multisets or repeated function +// application. +axiom FromSender_charn: // [use_induction]: + // "All m S k0 lid k args check #i. + "All lid k args #i #j. + // FromSender(m, S, k0, check) @ i + Success(lid) @ i + & CheckLoop(lid, k, args) @ j + ==> + (Ex #c. ChainKey(k) @ c) + " + +lemma authentic [use_induction]: + " (All m S k check #i. + FromSender(m, S, k, check) @ i + ==> + (Ex #j. Sent(m) @ j & j < i) + // | (Ex #j. RevealLtk(S) @ j & j < i) + ) + " + + +end diff --git a/data/examples/loops/TESLA_Scheme2_lossless.spthy b/data/examples/loops/TESLA_Scheme2_lossless.spthy new file mode 100644 --- /dev/null +++ b/data/examples/loops/TESLA_Scheme2_lossless.spthy @@ -0,0 +1,206 @@ +theory TESLA_Scheme2_lossless begin + +/* + Protocol: The TESLA protocol, scheme 2 (no re-authentication) + Modeler: Simon Meier + Date: September 2012 + + Status: working + + Original descrption in [1]. This model is based on the following description + from [2]. + + Msg 0a. R -> S : nR + Msg 0b. S -> R : {k0 , nR }SK (S ) + Msg 1. S -> R : m1 , MAC (k1 , m1 ). + + And for n > 1: + Msg n. S -> R : Dn , MAC (kn , Dn ) where Dn = mn , kn-1 . + + Here, we model a simplified version of Scheme 2, which does not allow a + receiver to re-authenticate once it missed a packet. We have not yet managed + to verify a model that allows this re-authentication. See + TESLA_Scheme2.spthy for more information on the problem. + + We verify that the use of cryptography is correct under the assumption that + the security condition holds. We do not verify that the timing schedule + works, as we do not have a notion of time. For a manual, but machine-checked + verification of the Scheme 2 of the TESLA protocol with time see [3]. + + + [1] Perrig, Adrian, Ran Canetti, Dawn Song, and Doug Tygar. "The TESLA + Broadcast Authentication Protocol." In RSA Cryptobytes, Summer 2002. + + [2] Philippa J. Hopcroft, Gavin Lowe: Analysing a stream authentication + protocol using model checking. Int. J. Inf. Sec. 3(1): 2-13 (2004) + + [3] David A. Basin, Srdjan Capkun, Patrick Schaller, Benedikt Schmidt: + Formal Reasoning about Physical Properties of Security Protocols. ACM Trans. + Inf. Syst. Secur. 14(2): 16 (2011) + +*/ + +builtins: signing + +functions: MAC/2, f/1 + +// PKI +////// + +rule Generate_Keypair: + [ Fr(~ltk) ] + --> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ] + +// We assume an active adversary. +rule Reveal_Ltk: + [ !Ltk(A, ltk) ] + --[ RevealLtk(A) ]-> + [ Out(ltk) ] + + +// Chain setup phase +//////////////////// + +// Hash chain generation +rule Gen_Start: + [ Fr(~seed) ] --> [ Gen(~seed) ] + +// The NextKey-facts are used by the sender rules to store the link between +// the keys in the chain. +rule Gen_Step: + [ Gen(chain) ] + --[ ChainKey(f(chain)) ]-> + [ Gen( f(chain) ) , NextKey( f(chain) , chain ) ] + +// At some point the sender decides to stop the hash-chain precomputation. +rule Gen_Stop: + [ Gen(kZero) ] + --[ Expired(kZero) ]-> + [ Sender1( $S, kZero) , !Sender0($S, kZero) ] + +// Intial chain key distribution +//////////////////////////////// + +// Everybody can listen in by sending a request for k_0. +rule Sender0: + let msgZero = + in + [ !Sender0(S, kZero), !Ltk(S, ltkS), In(nR) ] + --> + [ Out( ) ] + +// Receivers start by requesting key k_0 adn verifying the signature on this +// response. +rule Receiver0a: + [ Fr(~nR) ] --> [ Receiver0b($S, ~nR), Out(<$S, ~nR>) ] + +rule Receiver0b: + let msgZero = + in + [ Receiver0b(S,nR), !Pk(S, pkS), In() ] + --[ Eq( verify(signature, msgZero, pkS), true() ) ]-> + [ Receiver1(S,kZero) ] + +// Sending +////////// + +rule Sender1: + let msgOne = + in + [ Sender1( S, kZero ), NextKey( kZero, kOne ), Fr(mOne) ] + --[ Sent(S, msgOne) ]-> + [ SenderN( S, kOne ), Out( msgOne ) ] + +// We use the convention that k_{n-1} is denoted as kNp, where the 'p' stands +// for predecessor. +rule SenderN: + let msgN = + in + [ SenderN( S, kNp ), NextKey( kNp, kN), Fr(mN) ] + --[ Expired( kNp ) + , Sent( S, msgN ) + ]-> + [ SenderN( S, kN ), Out(msgN) ] + +// Receiving +//////////// + +rule Receiver1: + let msgOne = + in + [ Receiver1(S, kZero), In( msgOne ), Fr(expiryCheckOne) ] + --[ NotExpiredHere(expiryCheckOne) ]-> + [ ReceiverN(S, kZero, expiryCheckOne, msgOne, mOne, macOne ) ] + +rule ReceiverN: + let msgN = + in + [ ReceiverN(S, kNpp, expiryCheckNp, msgNp, mNp, macNp), In( msgN ) + , Fr(expiryCheckN) + ] + --[ Eq( kNpp, f(kNp) ), Eq( macNp, MAC(kNp, mNp) ) + // This action claims that 'msgNp' was sent by the sender provided that + // the longterm-key of 'S' was not revealed before and the key 'kNp' + // expired after the expiry check denoted by 'expiryCheckNp'. + , FromSender(msgNp, S, kNp, expiryCheckNp) + , NotExpiredHere( expiryCheckN ) + ]-> + [ ReceiverN(S, kNp, expiryCheckN, msgN, mN, macN ) ] + +// Axioms; i.e., universal restrictions on the traces of interest +///////////////////////////////////////////////////////////////// + +// We are only interested in traces where all equality checks succeed. +axiom Eq_checks_succeed: "(All x y #j. Eq(x, y) @ j ==> x = y)" + +// The security condition of TESLA guarantees that a key never expires +// before the receiver considers it to be expired. This means that we assume +// that the clocks are synchronized. Then, the clock checks are sufficient to +// guarantee this property. +axiom Security_condition: + "All m S k check #i #j #e. + FromSender(m, S, k, check) @ i + & NotExpiredHere(check) @ j + & Expired(k) @ e + ==> + j < e" + + +// Security properties +////////////////////// + +// Sanity check: there is a honest execution where no key expired too early. +lemma honestly_executable: + exists-trace + " ( Ex m S k check #i #j. + FromSender(m, S, k, check) @ i + & Sent(S, m) @ j + ) + & (All S #r. RevealLtk(S) @ r ==> F) // no longterm key was revealed + " + +// The following two lemmas constraint the search space strongly enough to +// allow reasoning about the authenticity of the received messages. + +lemma chain_keys_unique [use_induction, reuse]: + "All k #i #j. ChainKey(k) @ i & ChainKey(k) @ j ==> #i = #j" + +lemma knows_only_expired_chain_keys [use_induction, reuse]: + "All k #i #j. ChainKey(k) @i & KU(k) @ j ==> + (Ex #e. Expired(k) @ e & e < j)" + +// The desired security property: +lemma authentic [use_induction]: + " (All m S k check #i. + /* Whenever the reciever states that it received an authentic message, */ + FromSender(m, S, k, check) @ i + ==> + /* the sender sent it */ + (Ex #j. Sent(S, m) @ j & j < i) + /* or the adversary revealed the longterm key of the sender. */ + | (Ex #j. RevealLtk(S) @ j & j < i) + ) + " + +end diff --git a/data/examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy b/data/examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy --- a/data/examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy +++ b/data/examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy @@ -7,115 +7,185 @@ * * Status: working + [1] Sebastian Moedersheim: Abstraction by set-membership: verifying security protocols and web services with databases. ACM Conference on Computer and Communications Security 2010: 351-360 - */ -/* Original input file from [1] + The original model from [1]. -Problem: zebsKeyserver; + Problem: zebsKeyserver; -Types: -Agent : {a,b,c,i,s}; -U : {a,b,c}; -S : {s}; -H : {a,b}; -D : {c,i}; -DU : {c}; -Sts : {valid,revoked}; -PK,NPK : value; -M1,M2 : untyped; + Types: + Agent : {a,b,c,i,s}; + U : {a,b,c}; + S : {s}; + H : {a,b}; + D : {c,i}; + DU : {c}; + Sts : {valid,revoked}; + PK,NPK : value; + M1,M2 : untyped; -Sets: -ring(U), db(S,U,Sts); + Sets: + ring(U), db(S,U,Sts); -Functions: -public sign/2, pair/2; -private inv/1; + Functions: + public sign/2, pair/2; + private inv/1; -Facts: -iknows/1, attack/0; + Facts: + iknows/1, attack/0; -Rules: + Rules: -\Agent. => iknows(Agent); -iknows(sign(M1,M2)) => iknows(M2); -iknows(M1).iknows(M2) => iknows(sign(M1,M2)); -iknows(pair(M1,M2)) => iknows(M1).iknows(M2); -iknows(M1).iknows(M2) => iknows(pair(M1,M2)); + \Agent. => iknows(Agent); + iknows(sign(M1,M2)) => iknows(M2); + iknows(M1).iknows(M2) => iknows(sign(M1,M2)); + iknows(pair(M1,M2)) => iknows(M1).iknows(M2); + iknows(M1).iknows(M2) => iknows(pair(M1,M2)); + + \H,S. =[PK]=>iknows(PK).PK in ring(H).PK in db(S,H,valid); + + \S,DU. =[PK]=>iknows(PK).iknows(inv(PK)).PK in db(S,DU,valid); + + \H. + iknows(PK).PK in ring(H) + =[NPK]=>NPK in ring(H).iknows(sign(inv(PK),pair(H,NPK))); + + \S,U. + iknows(sign(inv(PK),pair(U,NPK))).PK in db(S,U,valid). + forall U,Sts. NPK notin db(S,U,Sts) + =>PK in db(S,U,revoked).NPK in db(S,U,valid).iknows(inv(PK)); + + \S,H. + iknows(inv(PK)).PK in db(S,H,valid) + =>attack; + + Unfortunately, there are no comments. Moreover, public keys are converted + freely to private keys, which is not always faithful. We comment on this + below. */ builtins: signing -// The non-deterministic choice between the rules SetupHonestKey and -// SetupDishonestKey determines whether an agent is honest or not. +/* We also setup a server key to allow server signatures. */ +rule SetupServerKey: + [ Fr(~sk) ] + --> + [ !ServerSK(~sk), !ServerPK(pk(~sk)), Out(pk(~sk)) ] -// \H,S. =[PK]=>iknows(PK).PK in ring(H).PK in db(S,H,valid); +/* + The non-deterministic choice between the rules SetupHonestKey and + SetupDishonestKey determines whether an agent is honest or not. + + The rule below models + + \H,S. =[PK]=>iknows(PK).PK in ring(H).PK in db(S,H,valid); + + Note that servers store public keys and clients store their private key. + There may be several registered keys at the same time, as there may be + multiple ServerKey-facts in the state at the same time. +*/ rule SetupHonestKey: [ Fr(~sk) ] --[ HonestKey(~sk) ]-> - [ Out(pk(~sk)), ClientKey($A, ~sk), ServerDB($A, ~sk) ] + [ Out(pk(~sk)) , ClientKey($A, ~sk) , ServerDB($A, pk(~sk)) ] -// \S,DU. =[PK]=>iknows(PK).iknows(inv(PK)).PK in db(S,DU,valid); + +/* The intruder may register any private key for any agent. + + \S,DU. =[PK]=>iknows(PK).iknows(inv(PK)).PK in db(S,DU,valid); + +*/ rule SetupDishonestKey: - [ In(sk) ] - --> - [ ServerDB($A, sk) ] + [ In(sk) ] --> [ ServerDB($A, pk(sk)) ] -// \H. -// iknows(PK).PK in ring(H) -// =[NPK]=>NPK in ring(H).iknows(sign(inv(PK),pair(H,NPK))); -rule RequestRenewKey: - [ ClientKey($A, sk), Fr(~skNew) ] +/* A client may renew one of his keys by sending a renew request. In [1], the + server then leaks the corresponding private key. This is not really + possible, as the server does not know the private keys corresponding to + newly setup keys. We model that the key waits for a confirmation of his + request and only then leaks his key + + The original client request rule was: + + \H. + iknows(PK).PK in ring(H) + =[NPK]=>NPK in ring(H).iknows(sign(inv(PK),pair(H,NPK))); +*/ +rule Client_RenewKey: + let pkNew = pk(~skNew) + request = <'renew', $A, pkNew> + requestSig = sign{request}~sk + in + [ ClientKey($A, ~sk), Fr(~skNew) ] --[ HonestKey(~skNew) ]-> - [ Out( sign{'renew', $A, pk(~skNew)}sk ) + [ Out( ) , ClientKey($A, ~skNew) + , AwaitConfirmation(requestSig,~sk) ] -// \S,U. -// iknows(sign(inv(PK),pair(U,NPK))).PK in db(S,U,valid). -// forall U,Sts. NPK notin db(S,U,Sts) -// =>PK in db(S,U,revoked).NPK in db(S,U,valid).iknows(inv(PK)); -rule RenewKey: - [ In( sign{'renew', A, pk(skNew)}sk ) - , ServerDB(A, sk) - ] - --[ Revoked(sk) ]-> - [ ServerDB(A, skNew) - , Out( sk ) +rule Client_LeakKey: + [ AwaitConfirmation(request,sk) + , !ServerPK(pkServer) + , In(sig) ] + --[ Eq(verify(sig, <'confirm', request>, pkServer), true) + , Revoked(sk) + ]-> + [ Out(sk) ] -// Typing lemma: it can be proven, but not with the current heuristic. It -// focuses too much on the first-order part and neglects solving the -// signature. Moreover, it should use an age-based strategy for the goals to -// ensure that it always makes at least some progress. -lemma types [typing]: - "All sk #i. Revoked(sk) @ i ==> - ( (Ex #j. KU(sk) @ j & j < i) - | (Ex #j. HonestKey(sk) @ j & j < i) - ) - " -/* -The following property proven in Moedersheim's paper is rather easy to -prove, as it depends only on the fact that secret keys are not leaked by -any other means than the "RenewKey" rule. The "RenewKey" rule always log's -that the key is "Revoked", which directly implies the lemma below. +/* The server updating his database. See the comment above for the change in + leaking the private key. The original rule in [1] is -TODO: Prove property that depends on ordering of revocation. For example, -DH-key exchange always succeeds for a protocol with an online key-server. This -crucially depends on the client not sending a renewal message while he's -waiting for the key confirmation. + \S,U. + iknows(sign(inv(PK),pair(U,NPK))).PK in db(S,U,valid). + forall U,Sts. NPK notin db(S,U,Sts) + =>PK in db(S,U,revoked).NPK in db(S,U,valid).iknows(inv(PK)); + + The leaking of 'inv(PK)' is unrealistic as the server only learns the + public key of new messages. */ +rule Server_RenewKey: + let request = <'renew', A, pkNew> + in + [ In( ) + , ServerDB(A, pk(sk)) + , !ServerSK(skServer) + ] + --[ Eq(verify(requestSig, request, pk(sk)), true) + ]-> + [ ServerDB(A, pkNew) + , Out(sign{'confirm', requestSig}skServer) + ] +// We assume that rule's are only executed if their equality checks succeed. +axiom Eq_checks_succeed: "All x y #i. Eq(x,y) @ i ==> x = y" -// \S,H. -// iknows(inv(PK)).PK in db(S,H,valid) -// =>attack; -lemma In_Honest_Key_imp_Revoked: +/* The following property proven in Moedersheim's paper is rather easy to + prove, as it depends only on the fact that secret keys are not leaked by + any other means than the "RenewKey" rule. The "RenewKey" rule always log's + that the key is "Revoked", which directly implies the lemma below. + + \S,H. + iknows(inv(PK)).PK in db(S,H,valid) + =>attack; +*/ + +lemma Knows_Honest_Key_imp_Revoked: "All sk #i #d. HonestKey(sk) @ i & K(sk) @ d ==> (Ex #r. Revoked(sk) @ r) " +/* +/* Sanity check. Commented out for runtime comparison to [1]. */ +lemma Honest_Revoked_Known_Reachable: + exists-trace + "(Ex sk #i #j #r. HonestKey(sk) @ i + & K(sk) @ j + & Revoked(sk) @ r + )" +*/ end + diff --git a/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Example1.spthy b/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Example1.spthy deleted file mode 100644 --- a/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Example1.spthy +++ /dev/null @@ -1,149 +0,0 @@ -theory StatVerif_Example1 begin - -/* - Protocol: Simple security device (Example 1 from [1]) - Modeler: Simon Meier - Date: May 2012 - - Status: working - - This is the simple security device example presented in Section V.A of the - following paper. - - [1] M. Arapinis, E. Ritter and M. Ryan. StatVerif: Verification of Stateful - Processes. In CSF'11. IEEE Computer Society Press, pages 33-47 , 2011. - - It models a hardware device that stores both a private key and a - configuration register that can be set to 'left' for decrypting the first - component of tuples encrypted using the device's public key and 'right' for - decrypting the second component of tuples encrypted using the device's - public key. Alice uses such a device to encrypt tuples such that Bob - can access either all their first components or all their second - components, but never both. - - Note that in contrast to [1], we allow the creation of an unbounded number - of devices. We also verify both the accessibility of left and right - components, as well as their exclusivity. The source code of the model - from [1] is attached at the end of this file. - -*/ - -builtins: asymmetric-encryption - - -// Create a new device. It stores the private key and publishes the -// corresponding public key. -rule NewDevice: - [ Fr(~sk) // We let the key identify the device. - ] - --> - [ UnconfiguredDevice(~sk) - , !DevicePublicKey(pk(~sk)) - , Out(pk(~sk)) - ] - -// Alice can use any public key associated to such a hardware security device -// for publishing messages with exclusive access. -rule Alice: - [ Fr(~x) - , Fr(~y) - , !DevicePublicKey(key) - ] - --[ Exclusive(~x,~y) ]-> - [ Out( aenc{~x,~y}key ) - ] - -// Unconfigured devices can be configured exactly once. -rule ConfigureDevice: - [ UnconfiguredDevice(sk), In(config) ] - --> - [ !ConfiguredDevice(sk, config) ] - -// Devices configured to 'left' can be used to decrypt the first component of -// messages encrypted using the device's public key. -rule UseLeftDevice: - [ !ConfiguredDevice(sk, 'left'), In(aenc{x,y}pk(sk)) ] - --[ Access(x) ]-> - [ Out(x) ] - -// Devices configured to 'right' can be used to decrypt the second component of -// messages encrypted using the device's public key. -rule UseRightDevice: - [ !ConfiguredDevice(sk, 'right'), In(aenc{x,y}pk(sk)) ] - --[ Access(y) ]-> - [ Out(y) ] - - -// As we use a backwards search, we must specify the possible structure of -// messages sent in 'UseLeftDevice' and 'UseRightDevice' precise enough such -// that we can solve all chain constraints starting from the sent message. We -// therefore log the message being accessed and relate it to its possible -// origins: known to the intruder in an earlier step or part of an exclusive -// message generated by 'Alice'. Typing lemmas are proven by induction and -// incorporated in the case distinction precomputation. -lemma types [typing]: - "All m #i. Access(m) @ i ==> - (Ex #j. KU(m) @ j & j < i) // Make use of the KU-facts logged - // by the construction rules. - | (Ex x #j. Exclusive(x,m) @ j) - | (Ex y #j. Exclusive(m,y) @ j) - " - -// Check that there is some trace where the intruder knows the left message of -// an exclusive message-tuple. In contrast to the typing lemma, we use the -// standard 'K'-fact, which is logged by the built-in 'ISend' rule. -lemma reachability_left: - exists-trace - "Ex x y #i #j. Exclusive(x,y) @i & K(x) @ j" - -lemma reachability_right: - exists-trace - "Ex x y #i #k. Exclusive(x,y) @i & K(y) @ k" - -// Check that exclusivity is maintained -lemma secrecy: - "not(Ex x y #i #k1 #k2. - Exclusive(x,y) @i & K(x) @ k1 & K(y) @ k2 - ) - " - -end - -/* StatVerif source code of the original model from [1]. - -fun pair/2. -fun aenc/3. -fun pk/1. -free left. -free right. -free init. -free c. - -reduc - projl(pair(xleft, xright)) = xleft; - projr(pair(xleft, xright)) = xright; - adec(u, aenc(pk(u), v, w)) = w. - -query - att:vs,pair(sl,sr). - -let device = - out(c, pk(k)) | - ( ! lock(s); in(c, x); read s as y; - if y = init then - (if x = left then s := x; unlock(s) - else if x = right then s := x; unlock(s)) ) | - ( ! lock(s); in(c, x); read s as y; let z = adec(k, x) in - let zl = projl(z) in - let zr = projr(z) in - ((if y = left then out(c, zl); unlock(s)) | - (if y = right then out(c, zr); unlock(s)))). - -let user = - new sl; new sr; new r; - out(c, aenc(pk(k), r, pair(sl,sr))). - -process - new k; new s; [s |-> init] | device | ! user - -*/ diff --git a/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_GM_Contract_Signing.spthy b/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_GM_Contract_Signing.spthy new file mode 100644 --- /dev/null +++ b/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_GM_Contract_Signing.spthy @@ -0,0 +1,305 @@ +theory StatVerif_GM_Contract_Signing begin + +/* + Protocol: Contract Signing Protocol (Example 2 from [1]) + Modeler: Simon Meier + Date: September 2012 + + Status: working + + This is the contract signing example presented in Section V.B of the + following paper. + + [1] M. Arapinis, E. Ritter and M. Ryan. StatVerif: Verification of Stateful + Processes. In CSF'11. IEEE Computer Society Press, pages 33-47 , 2011. + + It models the two-party version of the contract signing protocol proposed + in + + [2] Juan A. Garay, Markus Jakobsson, and Philip D. MacKenzie. Abuse-free + optimistic contract signing. In Michael J. Wiener, editor, CRYPTO, volume + 1666 of Lecture Notes in Computer Science, pages 449–466. Springer, 1999. + + Note that in contrast to [1], we do not require any protocol-specific + abstraction, as we support reasoning about state under replication. + +*/ + +functions: + pk/1, sign/2, pcs/3, check_getmsg/2, checkpcs/5, true/0, convertpcs/2 + +equations: + // Checking and getting the message in a standard signature + check_getmsg(pk(xsk), sign(xsk, xm)) = xm + + , checkpcs(xc, pk(xsk), ypk, zpk, pcs(sign(xsk, xc), ypk, zpk)) = true() + + , convertpcs(zsk, pcs(sign(xsk, xc), ypk, pk(zsk))) = sign(xsk, xc) + /* + The above two equations are inspired by the following design decisions. + We model a private signature of a contract 'xc' that is + - meant for 'y' identified by his public key 'ypk' + - privately signed by 'x' using his private key 'xsk' + - to be converted by the trusted party 'z' identified by its public key + 'zpk' + using the term 'pcs(sign(xsk, xc), ypk, zpk)'. + + This term chan be checked against 'xc', 'pk(xsk)', ypk, and zpk using + the 'checkpcs' algorithm. + + It can be converted to a standard signature using the 'convertpcs' + algorithm provided one has access to the private key of the trusted + party. + + Note that we embedd the proper standard signature immediately into the + 'pcs' term, as the resulting equational theory is not subterm-convergent + otherwise. + */ + +// Setting up the trusted third party, i.e., choose its signing key +rule Setup_TTP: + [ Fr(seed) ] --> [ !TTP(seed), Out(pk(seed)) ] + +// Our goal is to check that the TTP cannot be abused to provide the adversary +// with both a certificate that the contract was resolved and a certificate +// that the contract was aborted. + +// The TTP answering an 'abort' request. +rule Abort1: + let msg = + abortSig = sign(skT, pcsig1) + in + [ !TTP(skT) + , In(<'abort', msg>) + ] + --[ // The TTP answers at most once per contract. + Answered(ct) + // Check signatures. This is essential. Try uncommenting it and check + // the resulting attacks. + , Eq(checkpcs(ct, pk1, pk2, pk(skT), pcsig1), true) + // Log this action for referencing it in properties + , Abort1(ct) + ]-> + [ Out(abortSig) ] + +// We refrain from modelling the repeated answering with the same answer. +// It would be easy to model, but does obviously not strengthen the adversary. + +// The TTP answering a resolve request by party 2. +rule Resolve2: + let msg = + sig1 = convertpcs(skT, pcsig1) + resolveSig = sign(skT, ) + in + [ !TTP(skT) + , In(<'resolve2', msg>) + ] + --[ // The TTP answers at most once per contract. + Answered(ct) + // Check signatures + , Eq(check_getmsg(pk2, sig2), ct) + , Eq(checkpcs(ct, pk1, pk2, pk(skT), pcsig1), true) + // Log this action for referencing it in properties + , Resolve2(ct) + ]-> + [ Out(resolveSig) ] + +// The TTP answering a resolve request by party 1. +rule Resolve1: + let msg = + sig2 = convertpcs(skT, pcsig2) + resolveSig = sign(skT, ) + in + [ !TTP(skT) + , In(<'resolve1', msg>) + ] + --[ // The TTP answers at most once per contract. + Answered(ct) + // Check signatures + , Eq(check_getmsg(pk1, sig1), ct) + , Eq(checkpcs(ct, pk2, pk1, pk(skT), pcsig2), true) + // Log this action for referencing it in properties + , Resolve1(ct) + ]-> + [ Out(resolveSig) ] + + +// Witnessing aborted contracts. +rule Witness_Aborted: + let abortC = sign(skT, pcs(sign(sk1, ct), pk(ysk), pk(skT))) + in + [ In(abortC), !TTP(skT) ] --[ AbortCert(ct) ]-> [] + +// Witnessing resolved contracts. +rule Witness_Resolved: + let resolveC = sign(skT, ) + in + [ In(resolveC), !TTP(skT) ] --[ ResolveCert(ct) ]-> [] + + +// Axiom: the TTP does not answer any request twice +axiom Answered_unique: + "All x #i #j. Answered(x) @ i & Answered(x) @ j ==> #i = #j" + +// Axiom: the TTP stops if an equality check fails +axiom Eq_checks_succeed: "All x y #i. Eq(x,y) @ i ==> x = y" + + +/* +Our desired goal: there is not contract where the adversary can present +both an abort-certificate and a resolve-certificate. This is what is +verified in [1]. It is almost trivial, as it only relies on the uniqueness +check and properly checking the signatures. + +TODO: Investigate more interesting properties. Especially properties from the +perspective of the local agents. +*/ +lemma aborted_and_resolved_exclusive: + "not (Ex ct #i #j. AbortCert(ct) @ i & ResolveCert(ct) @ j)" + +// Sanity checks: The terms reductions behave as expected. +lemma aborted_contract_reachable: + exists-trace + " (Ex ct #i. AbortCert(ct) @ i ) + // Ensure that this is possible with at most one Abort step. + & (All ct1 ct2 #i1 #i2 . + Abort1(ct1) @ i1 & Abort1(ct2) @ i2 ==> #i1 = #i2) + & (All ct #i. Resolve1(ct) @ i ==> F) + & (All ct #i. Resolve2(ct) @ i ==> F) + " + +lemma resolved1_contract_reachable: + exists-trace + " (Ex ct #i. ResolveCert(ct) @ i) + // Ensure that this is possible with at most one Resolve1 step. + & (All ct #i. Abort1(ct) @ i ==> F) + & (All ct1 ct2 #i1 #i2 . + Resolve1(ct1) @ i1 & Resolve1(ct2) @ i2 ==> #i1 = #i2) + & (All ct #i. Resolve2(ct) @ i ==> F) + " + +lemma resolved2_contract_reachable: + exists-trace + "(Ex ct #i. ResolveCert(ct) @ i) + // Ensure that this is possible with at most one Resolve1 step. + & (All ct #i. Abort1(ct) @ i ==> F) + & (All ct #i. Resolve1(ct) @ i ==> F) + & (All ct1 ct2 #i1 #i2 . + Resolve2(ct1) @ i1 & Resolve2(ct2) @ i2 ==> #i1 = #i2) + " + + +/* +Original code from [1]. There is a strange discrepance between the description +of the protocol in [1, Figure 5] and the implementation here. The Abort1 +process does not check for a private contract signature, but for a standard +signature. However, the query listed on [1, page 12] considers a TTP-signed +pcs as the abort-certificate. +*/ + +/* + +free c. +free init. +free ok. +free abort. +free resolve1. +free resolve2. +free aborted. +free resolved. +free wtn_contract. +free skA. +free skB. + +fun pair/2. +fun pk/1. +fun sign/2. +fun pcs/4. + +reduc projl(pair(xl, xr)) = xl. +reduc projr(pair(xl, xr)) = xr. + +reduc check_getmsg(pk(xsk), sign(xsk, xm)) = xm. + +reduc checkpcs(xc, pk(xsk), ypk, zpk, pcs(xsk, ypk, zpk, xc)) = ok. +reduc convertpcs(zsk, pcs(xsk, ypk, pk(zsk), xc)) = sign(xsk, xc). + +let T = + new skT; (out(c, pk(skT)) | ! C) + +let C = + new s; new ct; + [s -> pair(init, init)] | + out(c, ct); in(c, xpk1); in(c, xpk2); + ( ! Abort1 | ! Resolve2 | ! Resolve1 ) + +let Abort1 = + lock; + in(c, x); + let xcmd = projl(x) in + if xcmd = abort then + let y = projr(x) in + let yl = projl(y) in + let ycontract = projl(yl) in + let yparties = projr(yl) in + if yparties = pair(xpk1, xpk2) then + if ycontract = ct then + let ysig = projr(y) in + let ym = check_getmsg(xpk1, ysig) in + if ym = yl then + read s as ys; + let ystatus = projl(ys) in + (if ystatus = aborted then + let ysigs = projr(ys) in + out(c, ysigs); unlock) | + (if ystatus = init then + s := pair(aborted, sign(skT, y)); + out(c, sign(skT, y)); unlock) + +let Resolve2 = + lock; + in(c, x); + let xcmd = projl(x) in + if xcmd = resolve2 then + let y = projr(x) in + let ypcs1 = projl(y) in + let ysig2 = projr(y) in + let ycontract = check_getmsg(xpk2, ysig2) in + if ycontract = ct then + let ycheck = checkpcs(ct, xpk1, xpk2, pk(skT), ypcs1) in + if ycheck = ok then + read s as ys; + let ystatus = projl(ys) in + (if ystatus = resolved2 then + let ysigs = projr(ys) in + out(c, ysigs); unlock) | + (if ystatus = init then + let ysig1 = convertpcs(skT, ypcs1) in + s := pair(resolved2, sign(skT, pair(ysig1, ysig2))); + out(c, sign(skT, pair(ysig1, ysig2))); unlock) + +let Resolve1 = + lock; + in(c, x); + let xcmd = projl(x) in + if xcmd = resolve1 then + let y = projr(x) in + let ysig1 = projl(y) in + let ypcs2 = projr(y) in + let ycontract = check_getmsg(xpk1, ysig1) in + if ycontract = ct then + let ycheck = checkpcs(ct, xpk2, xpk1, pk(skT), ypcs2) in + if ycheck = ok then + read s as ys; + let ystatus = projl(ys) in + (if ystatus = resolved1 then + let ysigs = projr(ys) in + out(c, ysigs); unlock) | + (if ystatus = init then + let ysig2 = convertpcs(skT, ypcs2) in + s := pair(resolved1, sign(skT, pair(ysig1, ysig2))); + out(c, sign(skT, pair(ysig1,ysig2))); unlock) + +*/ + +end diff --git a/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Security_Device.spthy b/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Security_Device.spthy new file mode 100644 --- /dev/null +++ b/data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Security_Device.spthy @@ -0,0 +1,149 @@ +theory StatVerif_Security_Device begin + +/* + Protocol: Simple security device (Example 1 from [1]) + Modeler: Simon Meier + Date: May 2012 + + Status: working + + This is the simple security device example presented in Section V.A of the + following paper. + + [1] M. Arapinis, E. Ritter and M. Ryan. StatVerif: Verification of Stateful + Processes. In CSF'11. IEEE Computer Society Press, pages 33-47 , 2011. + + It models a hardware device that stores both a private key and a + configuration register that can be set to 'left' for decrypting the first + component of tuples encrypted using the device's public key and 'right' for + decrypting the second component of tuples encrypted using the device's + public key. Alice uses such a device to encrypt tuples such that Bob + can access either all their first components or all their second + components, but never both. + + Note that in contrast to [1], we allow the creation of an unbounded number + of devices. We also verify both the accessibility of left and right + components, as well as their exclusivity. The source code of the model + from [1] is attached at the end of this file. + +*/ + +builtins: asymmetric-encryption + + +// Create a new device. It stores the private key and publishes the +// corresponding public key. +rule NewDevice: + [ Fr(~sk) // We let the key identify the device. + ] + --> + [ UnconfiguredDevice(~sk) + , !DevicePublicKey(pk(~sk)) + , Out(pk(~sk)) + ] + +// Alice can use any public key associated to such a hardware security device +// for publishing messages with exclusive access. +rule Alice: + [ Fr(~x) + , Fr(~y) + , !DevicePublicKey(key) + ] + --[ Exclusive(~x,~y) ]-> + [ Out( aenc{~x,~y}key ) + ] + +// Unconfigured devices can be configured exactly once. +rule ConfigureDevice: + [ UnconfiguredDevice(sk), In(config) ] + --> + [ !ConfiguredDevice(sk, config) ] + +// Devices configured to 'left' can be used to decrypt the first component of +// messages encrypted using the device's public key. +rule UseLeftDevice: + [ !ConfiguredDevice(sk, 'left'), In(aenc{x,y}pk(sk)) ] + --[ Access(x) ]-> + [ Out(x) ] + +// Devices configured to 'right' can be used to decrypt the second component of +// messages encrypted using the device's public key. +rule UseRightDevice: + [ !ConfiguredDevice(sk, 'right'), In(aenc{x,y}pk(sk)) ] + --[ Access(y) ]-> + [ Out(y) ] + + +// As we use a backwards search, we must specify the possible structure of +// messages sent in 'UseLeftDevice' and 'UseRightDevice' precise enough such +// that we can solve all chain constraints starting from the sent message. We +// therefore log the message being accessed and relate it to its possible +// origins: known to the intruder in an earlier step or part of an exclusive +// message generated by 'Alice'. Typing lemmas are proven by induction and +// incorporated in the case distinction precomputation. +lemma types [typing]: + "All m #i. Access(m) @ i ==> + (Ex #j. KU(m) @ j & j < i) // Make use of the KU-facts logged + // by the construction rules. + | (Ex x #j. Exclusive(x,m) @ j) + | (Ex y #j. Exclusive(m,y) @ j) + " + +// Check that there is some trace where the intruder knows the left message of +// an exclusive message-tuple. In contrast to the typing lemma, we use the +// standard 'K'-fact, which is logged by the built-in 'ISend' rule. +lemma reachability_left: + exists-trace + "Ex x y #i #j. Exclusive(x,y) @i & K(x) @ j" + +lemma reachability_right: + exists-trace + "Ex x y #i #k. Exclusive(x,y) @i & K(y) @ k" + +// Check that exclusivity is maintained +lemma secrecy: + "not(Ex x y #i #k1 #k2. + Exclusive(x,y) @i & K(x) @ k1 & K(y) @ k2 + ) + " + +end + +/* StatVerif source code of the original model from [1]. + +fun pair/2. +fun aenc/3. +fun pk/1. +free left. +free right. +free init. +free c. + +reduc + projl(pair(xleft, xright)) = xleft; + projr(pair(xleft, xright)) = xright; + adec(u, aenc(pk(u), v, w)) = w. + +query + att:vs,pair(sl,sr). + +let device = + out(c, pk(k)) | + ( ! lock(s); in(c, x); read s as y; + if y = init then + (if x = left then s := x; unlock(s) + else if x = right then s := x; unlock(s)) ) | + ( ! lock(s); in(c, x); read s as y; let z = adec(k, x) in + let zl = projl(z) in + let zr = projr(z) in + ((if y = left then out(c, zl); unlock(s)) | + (if y = right then out(c, zr); unlock(s)))). + +let user = + new sl; new sr; new r; + out(c, aenc(pk(k), r, pair(sl,sr))). + +process + new k; new s; [s |-> init] | device | ! user + +*/ diff --git a/data/examples/related_work/TPM_DKRS_CSF11/Envelope.spthy b/data/examples/related_work/TPM_DKRS_CSF11/Envelope.spthy --- a/data/examples/related_work/TPM_DKRS_CSF11/Envelope.spthy +++ b/data/examples/related_work/TPM_DKRS_CSF11/Envelope.spthy @@ -1,21 +1,32 @@ theory TPM_Envelope begin -text{* Envelope protocol example from: +/* + Protocol: The Envelope protocol modeled according to [1] + Modeler: Simon Meier + Date: September 2012 + Status: Working -[1] Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal -Analysis of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 IEEE -24th Computer Security Foundations Symposium, 2011. + [1] Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal + Analysis of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 + IEEE 24th Computer Security Foundations Symposium, 2011. -Modeler: Simon Meier -Date: June 2012 -Status: No automatic proof (interactive proof possible) + Note that this model can also be verified for an arbitrary number of + reboots. This is an open problem in [1]. The verification relies on the + construction that we track all writes to the PCR-fact using the additional + PCR_Write-fact. This allows us then to descend in the hash chain by solving + PCR_Write-premises. -Note that this model incorporates an arbitrary number of reboots, which is an -open problem in [1]. The verification relies on the construction that we track -all writes to the PCR-fact using the additional PCR_Write-fact. This allows us -then to descend in the hash chain by solving PCR_Write-premises. + Note also that verification without a reboot takes 19 seconds on an Intel i7 + Quad Core laptop with 4GB RAM. This is two orders of magnitude faster than + the time reported for [1]; 35min according to + http://www.lsv.ens-cachan.fr/~delaune/TPM-PCR/. -*} + The verification with reboot takes 75 seconds on this Intel i7 laptop. The + key reason why both of these times are so high is that the heuristic has + trouble discerning between the useful looping goals and the useless ones. A + manual proof can be much shorter than the one automatically produced. + Investigating a better heuristic is future work. +*/ builtins: signing, asymmetric-encryption, hashing @@ -35,16 +46,21 @@ , Out(pk(~aik)) // publish the public key of the auth. id. key ] -// reset the PCR to 'pcr0' +// reset the PCR to 'pcr0'. The proof goes also through with reboot, but takes +// considerably longer: about 1m 20sec on my i7 laptop. However, this is only +// a problem with the heuristic. The interactively constructed proof given +// below requires only 28 steps and 0.5 seconds to check. +/* rule PCR_Reboot: - [ PCR(x) - , PCR_Write(x) - ] - --[ PCR_Write('pcr0') - ]-> - [ PCR_Write('pcr0') - , PCR('pcr0') - ] + [ PCR(x) + , PCR_Write(x) + ] + --[ PCR_Write('pcr0') + ]-> + [ PCR_Write('pcr0') + , PCR('pcr0') + ] +*/ // Extend the hash-chain in the PCR rule PCR_Extend: @@ -146,7 +162,16 @@ , Out(pk(~sk)) ] -// Automatically proven +// Axioms; i.e., restrictions on the traces of interest +/////////////////////////////////////////////////////// + +axiom PCR_Init_unique: + " All #i #j. PCR_Init() @ i & PCR_Init() @ j ==> #i = #j " + +// Security Properties +////////////////////// + +// Characterizing the values extractible via unbinding. lemma types [typing]: // Values created by the PCR_Unbind rule " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==> @@ -155,7 +180,8 @@ ) " -// Automatically proven +// Every read value was written once. This allows us to reason backwards and +// ensure that the PCR value becomes smaller. lemma PCR_Write_charn [reuse, use_induction]: // Values read from the PCR have been written to it beforehand. " (All x #i. PCR_Read(x) @ i ==> @@ -163,17 +189,107 @@ ) " -// Assuming that there is at most one instance of the PCR, -// the adversary (playing Bob) must not know a secret that Alice created and -// thinks that access to it was denied. -// -// Currently, we have to construct its proof manually. The key argument relies -// on following the PCR_Write-premises once their presence has been -// established via the PCR_Write_charn lemma. -lemma reachable_Denied: - "(All #i #j. PCR_Init() @ i & PCR_Init() @ j ==> #i = #j) - ==> - not(Ex s #i #j #k. Secret(s) @ i & Denied(s) @ j & K(s) @ k)" +// The desired security property: the adversary (Bob) cannot know a secret to +// which he officially denied having access. +lemma Secret_and_Denied_exclusive: + " not(Ex s #i #j #k. Secret(s) @ i & Denied(s) @ j & K(s) @ k)" +/* Note that the 28 steps of the proof below suffices to justify this lemma + even with the reboot rule enabled. The heuristic is stymied by the looping + PCR facts and acts too conservatively, thereby using significantly more + proof steps (7136) and time (74 seconds). +*/ +/* +simplify +solve( Alice1( n ) ▶₀ #i ) + case Alice1 + solve( !AIK( aik ) ▶₂ #i ) + case PCR_Init + solve( Alice2( n.1, ~s ) ▶₀ #j ) + case Alice2 + solve( !AIK( aik.1 ) ▶₁ #j ) + case PCR_Init + solve( !KU( sign(<'certkey', + h(), 'obtain'>), pk>, + ~aik) + ) @ #vk ) + case PCR_CertKey + solve( !KU( sign(<'certpcr', + h(), 'deny'>)>, + ~aik) + ) @ #vk.1 ) + case PCR_Quote + solve( PCR_Write( h(), + 'deny'>) + ) @ #j.2 ) + case PCR_Extend + solve( !KU( ~s ) @ #vk.2 ) + case Alice2 + by solve( !KU( ~sk ) @ #vk.5 ) + next + case PCR_Unbind + solve( !KU( aenc(~s, pk(~sk.1)) ) @ #vk.5 ) + case Alice2 + solve( PCR_Write( h(), + 'obtain'>) + ) @ #j.3 ) + case PCR_Extend + solve( PCR_Write( h(<'pcr0', ~n>) ) @ #j.4 ) + case Alice1 + solve( PCR_Write( h(<'pcr0', ~n>) ) @ #j.3 ) + case Alice1 + solve( PCR_Write( 'pcr0' ) ▶₂ #vr ) + case PCR_Init + solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.1 ) + case Alice1 + solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.2 ) + case PCR_Extend + by solve( !KU( ~n ) @ #vk.6 ) + qed + next + case PCR_Extend + by solve( !KU( ~n ) @ #vk.6 ) + qed + next + case PCR_Reboot + solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.1 ) + case Alice1 + solve( PCR_Write( h(<'pcr0', ~n>) ) ▶₀ #j.2 ) + case PCR_Extend + by solve( !KU( ~n ) @ #vk.6 ) + qed + next + case PCR_Extend + by solve( !KU( ~n ) @ #vk.6 ) + qed + qed + next + case PCR_Extend + by solve( !KU( ~n ) @ #vk.6 ) + qed + next + case PCR_Extend + by solve( !KU( ~n ) @ #vk.6 ) + qed + qed + next + case caenc + by contradiction + qed + qed + qed + next + case csign + by solve( !KU( ~aik ) @ #vk.5 ) + qed + next + case csign + by solve( !KU( ~aik ) @ #vk.4 ) + qed + qed + qed + qed +qed +*/ end diff --git a/data/examples/related_work/TPM_DKRS_CSF11/RunningExample.spthy b/data/examples/related_work/TPM_DKRS_CSF11/RunningExample.spthy deleted file mode 100644 --- a/data/examples/related_work/TPM_DKRS_CSF11/RunningExample.spthy +++ /dev/null @@ -1,123 +0,0 @@ -theory CSF11_RunningExample begin - -text{* Running example from: - -Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal Analysis -of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 IEEE 24th -Computer Security Foundations Symposium, 2011. - -Modeler: Simon Meier -Date: June 2012 -Status: Working - -*} - -builtins: hashing, asymmetric-encryption, signing - -// TPM PCR model -rule PCR_Init: - [ Fr(~aik) // Authentication identity key - ] - --[ PCR_Init('pcr0',~aik) - , UniqueInit() // For removing traces that have multiple initializations - ]-> - [ PCR('pcr0') // the initial PCR value is 'pcr0' - , !AIK(~aik) // the auth. id. key is persistent - , Out(pk(~aik)) // publish the public key of the auth. id. key - ] - - -// Disabled, as the protocol is not secure under reboots. -// TODO: Check that we can find the attack. -// -// Note that we miss the attack, as we do not consider collapsing different -// PCR_Unbind nodes. In order to find this attack, we would require to -// introduce strongly different node variables. -// -// rule PCR_Reboot: -// [ PCR(x) ] --> [ PCR('pcr0') ] // reset the PCR to 'pcr0' - -rule PCR_Extend: - [ PCR(x) - , In(y) - ] - --[ PCR_Extend(x,y,h(x,y)) - ]-> - [ PCR(h(x,y)) - ] - -rule PCR_CertKey: - [ !AIK(aik) - , !KeyTable(x, sk) - ] - --[ PCR_CertKey_Inst(x) - ]-> - [ Out(sign{'certkey', x, pk(sk)}aik) ] - -rule PCR_Unbind: - [ PCR(x) - , !KeyTable(x, sk) - , In( aenc{m}pk(sk) ) - ] - --[ PCR_Unbind(x,sk,m) - ]-> - [ PCR(x) - , Out(m) ] - -// Alice -rule Alice_Init: - [ Fr(~s0) - , Fr(~s1) - , !AIK(aik) - , In(sign{'certkey', x0, pk0}aik) - , In(sign{'certkey', x1, pk1}aik) - ] - --[ Ineq(x0, x1) - , Secrets(~s0,~s1) - ]-> - [ Out(aenc{~s0}pk0) - , Out(aenc{~s1}pk1) - ] - -// Keytable -rule MkKey: - // Fr(<'MkKey',$a>) // register at most one key per public constant - [ Fr(~ska) ] - --> - [ !KeyTable(h('pcr0',$a), ~ska) ] - -lemma types [typing]: - " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==> - (Ex #j. KU(m) @ j & j < i) - | (Ex s #j. Secrets(m, s) @ j) - | (Ex s #j. Secrets(s, m) @ j) - ) - " - -lemma Unbind_PCR_Value [reuse, use_induction]: - "All x sk m #i. - PCR_Unbind(x, sk, m) @ i - ==> - ( (Ex aik #j. PCR_Init(x, aik) @ j ) - | (Ex y xPrev #j. PCR_Extend(xPrev,y,x) @ j) - | (Ex #i #j. UniqueInit() @ j & UniqueInit() @ i & not (#i = #j)) - ) - " - -lemma secrecy: - " ( (All #i #j. UniqueInit() @ j & UniqueInit() @ i ==> #i = #j) - & (All t #e. Ineq(t,t) @ e ==> F) - ) ==> - not( (Ex s0 s1 #i #d0 #d1. - Secrets(s0, s1) @ i - & K(s0) @ d0 - & K(s1) @ d1 - ) )" - - - - - - - -end diff --git a/data/examples/related_work/TPM_DKRS_CSF11/TPM_Exclusive_Secrets.spthy b/data/examples/related_work/TPM_DKRS_CSF11/TPM_Exclusive_Secrets.spthy new file mode 100644 --- /dev/null +++ b/data/examples/related_work/TPM_DKRS_CSF11/TPM_Exclusive_Secrets.spthy @@ -0,0 +1,167 @@ +theory TPM_Exclusive_Secrets begin + +/* + Protocol: Running example from [1] + Modeler: Simon Meier + Date: September 2012 + Status: Working + + [1] Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal + Analysis of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 + IEEE 24th Computer Security Foundations Symposium, 2011. + + The goal of this example is to verify that the adversary cannot exploit + his TPM to simultainously access the two secrets that were encryped + exclusively by Alice. + + Note that we could easily model multiple PCR's, if required. + +*/ + +builtins: hashing, asymmetric-encryption, signing + +// TPM Model with support for a single PCRs +/////////////////////////////////////////// + +rule PCR_Init: + [ Fr(~aik) // Authentication identity key + ] + --[ PCR_Init('pcr0',~aik) + , UniqueInit() // For removing traces that have multiple initializations + ]-> + [ PCR('pcr0') // the initial PCR value is 'pcr0' + , !AIK(~aik) // the auth. id. key is persistent + , Out(pk(~aik)) // publish the public key of the attest. ident. key + ] + + +// Disabled, as the protocol is not secure under reboots. +// +// Note that we miss the attack, as we do not consider collapsing different +// PCR_Unbind nodes by default. The general construction would require +// distinctness constraints on temporal variables. We can however simulate it +// by proving a simple case distinction lemma with a 'reuse' attribute, as +// demonstrated below. +// +// rule PCR_Reboot: +// [ PCR(x) ] --> [ PCR('pcr0') ] // reset the PCR to 'pcr0' + +// Extending the PCR register with the value 'y' +rule PCR_Extend: + [ PCR(x) , In(y) ] --[ PCR_Extend(x,y,h(x,y)) ]-> [ PCR(h(x,y)) ] + +// Create a fresh key that is bound to 'pcr0' extended with a public +// constant. +rule PCR_CreateKey: + [ Fr(~ska) ] --> [ !KeyTable(h('pcr0',$a), ~ska) ] + +// Certifying a key using the TPM's Attestation Identity Key (AIK) +rule PCR_CertKey: + [ !AIK(aik) + , !KeyTable(x, sk) // Any key in the keytable can be certified. + ] + --[ PCR_CertKey_Inst(x) + ]-> + [ Out(sign{'certkey', x, pk(sk)}aik) ] + +// Keys in the keytable are bound to a fixed PCR value. If this value, agrees +// with the actual PCR value, then the TPM can be used to decrypt messages +// encrypted with these keys. +rule PCR_Unbind: + [ PCR(x) + , !KeyTable(x, sk) + , In( aenc{m}pk(sk) ) + ] + --[ PCR_Unbind(x,sk,m) + ]-> + [ PCR(x) , Out(m) ] + +// Alice generates two secrets and accepts two *different* keys signed by the +// TPM to provide exlusive access to them. We are a bit lazy here and use +// pattern matching for the signature verification. +rule Alice_Init: + [ Fr(~s0) + , Fr(~s1) + , !AIK(aik) + , In(sign{'certkey', x0, pk0}aik) + , In(sign{'certkey', x1, pk1}aik) + ] + --[ InEq(x0, x1) + , Secrets(~s0,~s1) + ]-> + [ Out(aenc{~s0}pk0) + , Out(aenc{~s1}pk1) + ] + + + +// Axioms; i.e., restrictions on the set of traces of interest +////////////////////////////////////////////////////////////// + +axiom UniqueInit_unique: + " All #i #j. UniqueInit() @ j & UniqueInit() @ i ==> #i = #j " + +axiom Ineq_checks_succeed: + " All t #e. InEq(t,t) @ e ==> F " + + +// Security Properties +////////////////////// + + +// A type invariant characterizing the values that can be learned using the +// TPM to Unbind (i.e., decrypt) messages. +lemma types [typing]: + " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==> + (Ex #j. KU(m) @ j & j < i) + | (Ex s #j. Secrets(m, s) @ j) + | (Ex s #j. Secrets(s, m) @ j) + ) + " + +// Characterizing the unbinding operation. This is the key lemma. It allows us +// to jump backwards to smaller values of the PCR register during reasoning. +lemma Unbind_PCR_charn [reuse, use_induction]: + "All x sk m #i. + // If the key 'sk' bound to PCR value 'x' is used to extract the body + // 'm' of an encryption, then + PCR_Unbind(x, sk, m) @ i + ==> + // 'x' is the initial PCR value + ( (Ex aik #j. PCR_Init(x, aik) @ j ) + // or it was the result of an extension. + | (Ex y xPrev #j. PCR_Extend(xPrev,y,x) @ j) + ) + " + +// Uncomment to perform case distinctions on the identity of different +// PCR_Unbind nodes. This is required to find the attack when using reboots. +/* +lemma PCR_Unbind_case_distinctions [reuse]: + "All d11 d21 m1 #i1 d12 d22 m2 #i2. + PCR_Unbind(d11, d21, m1) @ i1 + & PCR_Unbind(d12, d22, m2) @ i2 + ==> + (#i1 = #i2) | not(#i1 = #i2) + " +*/ + +// The desired security property +lemma exclusive_secrets: + " not(Ex s0 s1 #i #d0 #d1. + Secrets(s0, s1) @ i + & K(s0) @ d0 + & K(s1) @ d1 + )" + +// Sanity check: both secrets can be accessed individually. +lemma left_reachable: + exists-trace + " Ex s0 s1 #i #j. Secrets(s0, s1) @ i & K(s0) @ j " + +lemma right_reachable: + exists-trace + " Ex s0 s1 #i #j. Secrets(s0, s1) @ i & K(s1) @ j " + + +end diff --git a/data/examples/related_work/YubiSecure_KS_STM12/Yubikey.spthy b/data/examples/related_work/YubiSecure_KS_STM12/Yubikey.spthy new file mode 100644 --- /dev/null +++ b/data/examples/related_work/YubiSecure_KS_STM12/Yubikey.spthy @@ -0,0 +1,227 @@ +theory Yubikey +begin + +section{* The Yubikey-Protocol *} + +/* + * Protocol: Yubikey Protocol + * Modeler: Robert Kunnemann, Graham Steel + * Date: August 2012 + * + * Status: working + */ + +builtins: symmetric-encryption + +functions: S/1,zero/0 + +/* We to model the Yubikey protocol, described in +* http://www.yubico.com/documentation +* http://www.yubico.com/developers-intro +* This is simplified version, in particular: +* - timestamps are not modelled +* - We do not distinguish the session and token counter. We describe them +* as one single counter, that represents the pair (session counter, token +* counter) with a lexicographical order on the pair. This implies that +* a) pressing the button on the Yubikey increases this counter by 1, and +* b) a plugin of the Yubikey increases it by an arbitrary amount the +* adversary gets to choose (giving him more power). +*/ + +/* The following rules model two binary relations between integers. !Succ + * is functional. If !Succ(a,b), then the adversary was able to show that b + * is the successor of b. Similarly, albeit !Smaller is not functional, if + * !Smaller(a,b), then the adversary was able to show that a is smaller + * than b. + * The Theory() action is used to enforce that this relation (to the extend + * it is needed in this trace) has to be build up before running the first + * protocol actions. +*/ +rule InitSucc: + [In(zero),In(S(zero))] + --[Theory(), IsSucc(zero,S(zero)),IsZero(zero)]-> + [!Succ(zero,S(zero))] + +rule StepSucc: + [In(y),In(S(y)), !Succ(x,y)] + --[Theory(), IsSucc(y,S(y)) ]-> + [!Succ(y,S(y))] + +rule SimpleSmaller: + [!Succ(x,y)] + --[Theory(), IsSmaller(x,y)]-> + [!Smaller(x,y)] + +rule ZExtendedSmaller: + [!Smaller(x,y),!Succ(y,z)] + --[Theory(), IsSmaller(x,z)]-> + [!Smaller(x,z)] + +/* A Yubikey is initialised with a zero counter, a key and a public, as well as a + * secret identifier, ~pid and ~sid. This information is shared with the + * Authentication Server, so we assume a trusted way of installing a + * Yubikey +*/ +rule BuyANewYubikey: + [Fr(~k),Fr(~pid),Fr(~sid)] //for fresh k, public and secret id.. + --[Protocol(), Init(~pid,~k),ExtendedInit(~pid,~sid,~k),IsZero(zero)]-> + [!Y(~pid,~sid), Y_counter(~pid,zero), + //..store public and secret id along with the starting counter + //(zero) on the Yubikey.. + Server(~pid,~sid,zero),!SharedKey(~pid,~k), //and on the server + Out(~pid)] //and make the public id public + +//On plugin, the session counter is increased and the token counter reset +rule Yubikey_Plugin: + [Y_counter(pid,sc),!Smaller(sc, Ssc) ] + //The old counter value sc is removed + --[ Yubi(pid,Ssc) ]-> + [Y_counter(pid, Ssc)] + //and substituted by a new counter value, larger, Ssc + +//If the Button is pressed, the token counter is increased +rule Yubikey_PressButton: + [!Y(pid,sid), Y_counter(pid,tc),!SharedKey(pid,k), + !Succ(tc,Stc),Fr(~npr),Fr(~nonce) ] + //The old countervalue tc is removed + --[ YubiPress(pid,tc), YubiOTP(pid,senc(,k)), + YubiSid(pid,sid,k) ]-> + [Y_counter(pid, Stc), //and substituted by its successor + Out(,k)>) + //in addition, an encrypted otp is output along with a nonce and + //the public id of the Yubikey used. + ] + +/* Upon receiving an encrypted OTP, the Server compares the (unencrypted) + * public id to his data base to identify the key to decrypt the OTP. After + * making sure that the secret id is correct, the Server verifies that the + * received counter value is larger than the last one stored. If the Login + * is successful, i.e., the previous conditions were fulfilled, the counter + * value on the Server that is associated to the Yubikey is updated. + */ + +rule Server_ReceiveOTP_NewSession: + [Server(pid,sid,otc), In(,k)>), + !SharedKey(pid,k), !Smaller(otc,tc) ] + //if the Server receives an OTP encrypted with k that belongs to + //the (unencrypted) public id, and the OTP has the right format, + //contains the correct secret id as well as a counter tc that is + //larger than the current counter otc, then... + --[ Login(pid,sid,tc,senc(,k)), + LoginCounter(pid,otc,tc) //..the Login is accepted.. + ]-> + [Server(pid,sid,tc)] //..and the counter value updated. + +/* The following three axioms are conditions on the traces that make sure + * that : */ + +//a) the !Smaller relation is transitive +axiom transitivity: //axiomatic + "All #t1 #t2 a b c. IsSmaller(a,b)@t1 & IsSmaller(b,c)@t2 + ==> Ex #t3 . IsSmaller(a,c)@t3 " + +//b) !Smaller implies unequality +axiom smaller_implies_unequal: //axiomatic + "not (Ex a #t . IsSmaller(a,a)@t)" + +//c) The protocol runs only after the IsSmaller and IsSuccessor relation is +// build up +axiom theory_before_protocol: + "All #i #j. Theory() @ i & Protocol() @ j ==> i < j" + +// For sanity: Ensure that a successful login is reachable. +lemma Login_reachable: + exists-trace + "Ex #i pid sid x otp1. Login(pid,sid,x,otp1)@i" + +// Each succesful login with counter value x was preceeded by a PressButton +// event with the same counter value +lemma one_count_foreach_login[reuse,use_induction]: + "All pid sid x otp #t2 . Login(pid,sid,x,otp)@t2 ==> + ( Ex #t1 . YubiPress(pid,x)@#t1 & #t1<#t2 )" + +// If a succesful Login happens before a second sucesfull Login, the +// counter value of the first is smaller than the counter value of the +// second +lemma slightly_weaker_invariant[reuse, use_induction]: + "(All pid otc1 tc1 otc2 tc2 #t1 #t2 . + LoginCounter(pid,otc1,tc1)@#t1 & LoginCounter(pid,otc2,tc2)@#t2 + ==> ( #t1<#t2 & ( Ex #t3 . IsSmaller(tc1,tc2)@t3 )) + | #t2<#t1 | #t1=#t2) + " +induction + case empty_trace + by contradiction // from formulas +next + case non_empty_trace + simplify + solve( (∀ pid otc1 tc1 otc2 tc2 #t1 #t2. + (LoginCounter( pid, otc1, tc1 ) @ #t1) ∧ + (LoginCounter( pid, otc2, tc2 ) @ #t2) + ⇒ + (last(#t2)) ∨ + (last(#t1)) ∨ + ((#t1 < #t2) ∧ + (∃ #t3. (IsSmaller( tc1, tc2 ) @ #t3) ∧ ¬(last(#t3)))) ∨ + (#t2 < #t1) ∨ + (#t1 = #t2)) ∥ + (∃ #t1 #t2 a b c. + (IsSmaller( a, b ) @ #t1) ∧ (IsSmaller( b, c ) @ #t2) + ∧ + (¬(last(#t2))) ∧ + (¬(last(#t1))) ∧ + (∀ #t3. (IsSmaller( a, c ) @ #t3) ⇒ last(#t3))) ) + case case_1 + solve( (last(#t2)) ∥ (last(#t1)) ∥ + ((#t1 < #t2) ∧ + (∃ #t3. (IsSmaller( tc1, tc2 ) @ #t3) ∧ ¬(last(#t3)))) ∥ + (#t2 < #t1) ∥ (#t1 = #t2) ) + case case_1 + solve( Server( pid, sid, otc1 ) ▶₀ #t1 ) + case BuyANewYubikey + solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 ) + by sorry + next + case Server_ReceiveOTP_NewSession_case_1 + solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 ) + by sorry + next + case Server_ReceiveOTP_NewSession_case_2 + solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 ) + by sorry + next + case Server_ReceiveOTP_NewSession_case_3 + solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 ) + by sorry + next + case Server_ReceiveOTP_NewSession_case_4 + solve( Server( ~pid, sid.1, otc2 ) ▶₀ #t2 ) + by sorry + qed + next + case case_2 + by contradiction // cyclic + next + case case_3 + by contradiction // from formulas + next + case case_4 + by contradiction // from formulas + next + case case_5 + by contradiction // from formulas + qed + next + case case_2 + by sorry + qed +qed + +// It is not possible to have to distinct logins with the same counter +// value +lemma no_replay: + "not (Ex #i #j pid sid x otp1 otp2 . + Login(pid,sid,x,otp1)@i & Login(pid,sid,x,otp2)@j + & not(#i=#j))" +end + diff --git a/data/examples/related_work/YubiSecure_KS_STM12/Yubikey_and_YubiHSM.spthy b/data/examples/related_work/YubiSecure_KS_STM12/Yubikey_and_YubiHSM.spthy new file mode 100644 --- /dev/null +++ b/data/examples/related_work/YubiSecure_KS_STM12/Yubikey_and_YubiHSM.spthy @@ -0,0 +1,277 @@ +theory YubikeyHSM +begin + +section{* The Yubikey-Protocol with a YubiHSM *} + +/* + * Protocol: Yubikey Protocol with a YubiHSM + * Modeler: Robert Kunnemann, Graham Steel + * Date: August 2012 + * + * Status: working + */ + +builtins: symmetric-encryption + +functions: S/1,zero/0 + +/* We to model the Yubikey protocol, described in +* http://www.yubico.com/documentation +* http://www.yubico.com/developers-intro +* In this version, we assume the Authentication Server to be under the +* control of the attacker. We investigate the secrecy of keys in case the +* Authentication Server can protect the keys by encrypting them using a +* Hardware Token called YubiHSM, see: +* TODO URL will follow +* This is simplified version, in particular: +* - timestamps are not modelled +* - we do not distinguish the session and token counter. We described them +* as one single counter, that represents the pair (session counter, token +* counter) with a lexicographical oder on the pair. +* - we model encryption in more detail than the Theory Yubikey. However, +* we use a very much simplified model of XOR +* - we assume the YubiHSM to be in a configuration where only the flags +* YSM_AEAD_RANDOM_GENERATE and +* YSM_AEAD_YUBIKEY_OTP_DECODE +* are activated. +*/ + + + +/* keystream models the way the keystream used for encryption is computed. + * Mac describes the MAC used inside the AEADs, which are computed using + * CBC mode, described in RFC 3610. + * keystream_kh and keyhandle_n model the adversaries capacity to extract the + * used keyhandle and nonce that determined the keystream. (Similar for + * demac.) +*/ +functions: keystream/2, keystream_kh/1, keystream_n/1, + xorc/2, dexor1/2, dexor2/2, + mac/2, demac/2 +equations: keystream_kh(keystream(kh,n))=kh, + keystream_n(keystream(n,n))=n, +/* an incomplete way of modelling the algebraic properties of the XOR + * operator */ + dexor1(xorc(a,b),a)=b, + dexor2(xorc(a,b),b)=a, +/* using mac, adv might find out *something* about the message, we + * overapproximate */ + demac(mac(m,k),k)=m + +/* The following rules model two binary relations between integers. !Succ + * is functional. If !Succ(a,b), then the adversary was able to show that b + * is the successor of b. Similarly, albeit !Smaller is not functional, if + * !Smaller(a,b), then the adversary was able to show that a is smaller + * than b. + * The Theory() action is used to enforce that this relation (to the extend + * it is needed in this trace) has to be build up before running the first + * protocol actions. +*/ +rule InitSucc: + [In(zero),In(S(zero))] + --[Theory(), IsSucc(zero,S(zero)),IsZero(zero)]-> + [!Succ(zero,S(zero))] + +rule StepSucc: + [In(y),In(S(y)), !Succ(x,y)] + --[Theory(), IsSucc(y,S(y)) ]-> + [!Succ(y,S(y))] + +rule SimpleSmaller: + [!Succ(x,y)] + --[Theory(), IsSmaller(x,y)]-> + [!Smaller(x,y)] + +rule ZExtendedSmaller: + [!Smaller(x,y),!Succ(y,z)] + --[Theory(), IsSmaller(x,z)]-> + [!Smaller(x,z)] + +// Rules for intruder's control over Server + +/* The attacker can send messages to the HSM, i.e., on behalf of the + * authentication server. Likewise, he can receive messages. + */ + +rule isendHSM: + [ In( x ) ] --[ HSMWrite(x) ]-> [ InHSM( x ) ] +rule irecvHSM: + [ OutHSM( x ) ] --[ HSMRead(x) ]-> [Out(x)] + +/* The attacker can write and read the Authentication Server's database. + * This database contains a list of public ideas and corresponding AEADs + */ +rule read_AEAD: + [ !S_AEAD(pid,aead) ] --[ AEADRead(aead),HSMRead(aead) ]-> [Out(aead)] +rule write_AEAD: + [ In(aead), In(pid) ] --[ AEADWrite(aead),HSMWrite(aead) ]-> [!S_AEAD(pid,aead) ] + + +/* Initialisation of HSM and Authentication Server. OneTime() Assures that + * this can only happen a single time in a trace */ +rule HSMInit: + [Fr(~k), Fr(~kh)] --[Protocol(), GenerateRole1(~k),MasterKey(~k), OneTime()]-> + [ !HSM(~kh,~k), Out(~kh), +/* If the following line is uncommented, we are able to reproduce the + * attack described in + * http://static.yubico.com/var/uploads/pdfs/Security%20Advisory.pdf + */ +//!YSM_AEAD_GENERATE(~kh), //uncomment to produce attacks +!YSM_AEAD_YUBIKEY_OTP_DECODE(~kh) +] + +//Some commands on the HSM: +rule YSM_AEAD_RANDOM_GENERATE: + let ks=keystream(kh,N) + aead= + in + [Fr(~data), InHSM(),!HSM(kh,k),!YSM_AEAD_RANDOM_GENERATE(kh)] + --[GenerateRandomAEAD(~data)]-> + [OutHSM( aead) + ] + +rule YSM_AEAD_GENERATE: + let ks=keystream(kh,N) + aead= + in + [InHSM(),!HSM(kh,k),!YSM_AEAD_GENERATE(kh)] + --[GenerateAEAD(data,aead )]-> + [OutHSM( aead) ] + +rule YSM_AES_ESC_BLOCK_ENCRYPT: + [InHSM(), !HSM(kh,k), !YSM_AES_ESC_BLOCK_ENCRYPT(kh)] + --[]-> + [OutHSM(senc(data,k))] + +rule YSM_AEAD_YUBIKEY_OTP_DECODE: + let ks=keystream(kh,N) + aead=),mac(,k)> + otp=senc(,k2) + in + [InHSM(), !HSM(kh,k), !YSM_AEAD_YUBIKEY_OTP_DECODE(kh) + ] + --[ + OtpDecode(k2,k,,sc,xorc(senc(ks,k),),mac(,k)), + OtpDecodeMaster(k2,k) + ]-> + [OutHSM(sc)] + +//Yubikey operations +//(see Yubikey.spthy for more detailed comments) +rule BuyANewYubikey: + let ks=keystream(kh,~pid) + aead=),mac(<~k2,~sid>,~k)> + in +/* This rule implicitly uses YSM_AEAD_GENERATE to produce the AEAD that + * stores the secret identity and shared key of a Yubikey. By disabling the + * YSM_AEAD_GENERATE flag but nevertheless permitting this operation, we + * model a scenario where YSM_AEAD_GENERATE can be safely used to guarantee + * the operation, but not by the attacker. This corresponds to a scenario + * where Yubikey set-up takes place on a different server, or where the + * set-up takes place before the server is plugged into the network. + * Uncomment the following line to require the HSM to have the + * YSM_AEAD_GENERATE flag set. + */ +//!YSM_AEAD_GENERATE(kh), + [ Fr(~k2),Fr(~pid),Fr(~sid), + !HSM(kh,~k), + !Succ(zero,one) ] + --[Init(~pid,~k2)]-> + [Y_counter(~pid,one), !Y_Key(~pid,~k2), !Y_sid(~pid,~sid), + S_Counter(~pid,zero), !S_AEAD(~pid,aead), !S_sid(~pid,~sid), + Out(~pid) ] + +//On plugin, the session counter is increased and the token counter reset +rule Yubikey_Plugin: + [Y_counter(pid,sc),!Smaller(sc, Ssc) ] + //The old counter value sc is removed + --[ Yubi(pid,Ssc) ]-> + [Y_counter(pid, Ssc)] + //and substituted by a new counter value, larger, Ssc + +rule Yubikey_PressButton: + [Y_counter(pid,tc),!Y_Key(pid,k2),!Y_sid(pid,sid), + !Succ(tc,Stc),Fr(~pr),Fr(~nonce) ] + --[ YubiPress(pid,tc), + YubiPressOtp(pid,,tc,k2) ]-> + [Y_counter(pid,Stc), Out(,k2)>)] + +rule Server_ReceiveOTP_NewSession: + let ks=keystream(kh,pid) + aead=),mac(,k)> + in + [In(,k2)>) , + !HSM(kh,k), !S_AEAD(pid,aead), S_Counter(pid,otc), + !S_sid(pid,sid), !Smaller(otc,tc) ] + --[ Login(pid,sid,tc,senc(,k2)) ]-> + [ S_Counter(pid,tc) ] + +/* The following three axioms are conditions on the traces that make sure + * that : */ +// +//a) the !Smaller relation is transitive +axiom transitivity: //axiomatic + "All #t1 #t2 a b c. IsSmaller(a,b)@t1 & IsSmaller(b,c)@t2 + ==> Ex #t3 . IsSmaller(a,c)@t3 " + +//b) !Smaller implies unequality +axiom smaller_implies_unequal: //axiomatic + "not (Ex a #t . IsSmaller(a,a)@t)" + +/*c) The protocol runs only after the IsSmaller and IsSuccessor relation is + * build up + */ +axiom theory_before_protocol: + "All #i #j. Theory() @ i & Protocol() @ j ==> i < j" + +axiom onetime: + "All #t3 #t4 . OneTime()@#t3 & OneTime()@t4 ==> #t3=#t4" + +//LEMMAS: + +// For sanity: Ensure that a successful login is reachable. +//TODO reactivate +//lemma Login_reachable: +// exists-trace +// "Ex #i pid sid x otp1. Login(pid,sid, x, otp1)@i" + +/* Every counter produced by a Yubikey could be computed by the adversary + * anyway. (This saves a lot of steps in the backwards induction of the + * following lemmas). +*/ +lemma adv_can_guess_counter[reuse,use_induction]: + "All pid sc #t2 . YubiPress(pid,sc)@t2 + ==> (Ex #t1 . K(sc)@#t1 & #t1<#t2)" + +/* Everything that can be learned by using OtpDecode is the counter of a + * Yubikey, which can be computed according to the previous lemma. +*/ +lemma otp_decode_does_not_help_adv_use_induction[reuse,use_induction]: + "All #t3 k2 k m sc enc mac . OtpDecode(k2,k,m,sc,enc,mac)@t3 + ==> Ex #t1 pid . YubiPress(pid,sc)@#t1 & #t1<#t3" + +/* All keys shared between the YubiHSM and the Authentication Server are + * either not known to the adversary, or the adversary learned the key used + * to encrypt said keys in form of AEADs. + */ +lemma k2_is_secret_use_induction[use_induction,reuse]: + "All #t1 #t2 pid k2 . Init(pid,k2)@t1 & K(k2)@t2 + ==> + (Ex #t3 #t4 k . K(k)@t3 & MasterKey(k)@t4 & #t3<#t2)" + +/* Neither of those kinds of keys are ever learned by the adversary */ +lemma neither_k_nor_k2_are_ever_leaked_inv[use_induction,reuse]: + " +not( Ex #t1 #t2 k . MasterKey(k)@t1 & K(k)@t2 ) +& not (Ex #t5 #t6 k6 pid . Init(pid,k6)@t5 & K(k6)@t6 ) + " + +// Each succesful login with counter value x was preceeded by a PressButton +// event with the same counter value +// This lemma cannot be proven at the moment, but it would be a first step +// to reach the no_replay result present in Yubikey.spthy +//lemma one_count_foreach_login[reuse,use_induction]: +// "All pid sid x otp #t2 . Login(pid,sid,x,otp)@t2 ==> +// ( Ex #t1 . YubiPress(pid,x)@#t1 & #t1<#t2 )" + +end 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,8,1,0], versionTags = []} +version = Version {versionBranch = [0,8,2,0], versionTags = []} bindir, libdir, datadir, libexecdir :: FilePath bindir = "./" diff --git a/src/Main/Mode/Intruder.hs b/src/Main/Mode/Intruder.hs --- a/src/Main/Mode/Intruder.hs +++ b/src/Main/Mode/Intruder.hs @@ -18,11 +18,11 @@ import System.FilePath import Theory -import Theory.Text.Parser (intruderVariantsFile) import Theory.Tools.IntruderRules import Main.Console import Main.Environment +import Main.TheoryLoader (intruderVariantsFile) import Main.Utils diff --git a/src/Main/Mode/Test.hs b/src/Main/Mode/Test.hs --- a/src/Main/Mode/Test.hs +++ b/src/Main/Mode/Test.hs @@ -23,7 +23,7 @@ import qualified Term.UnitTests as Term (tests) import Theory -import qualified Theory.Text.Parser.UnitTests as Parser +import qualified Test.ParserTests as Parser -- | Self-test mode. diff --git a/src/Main/TheoryLoader.hs b/src/Main/TheoryLoader.hs --- a/src/Main/TheoryLoader.hs +++ b/src/Main/TheoryLoader.hs @@ -24,27 +24,37 @@ , closeThy + -- ** Message deduction variants + , intruderVariantsFile + , addMessageDeductionRuleVariants + ) where import Prelude hiding (id, (.)) import Data.Char (toLower) +import Data.Label +import Data.List (isPrefixOf) import Data.Monoid import Control.Basics import Control.Category -import Control.DeepSeq (rnf) +import Control.DeepSeq (rnf) +import Extension.Prelude (ifM) import System.Console.CmdArgs.Explicit +import System.Directory (doesFileExist) import Theory import Theory.Text.Parser import Theory.Text.Pretty import Theory.Tools.AbstractInterpretation (EvaluationStyle(..)) +import Theory.Tools.IntruderRules (specialIntruderRules, subtermIntruderRules) import Theory.Tools.Wellformedness import Main.Console import Main.Environment +import Paths_tamarin_prover (getDataFileName) ------------------------------------------------------------------------------ @@ -55,8 +65,8 @@ -- | Flags for loading a theory. theoryLoadFlags :: [Flag Arguments] theoryLoadFlags = - [ flagNone ["prove"] (addEmptyArg "addProofs") - "Attempt to prove all security properties" + [ flagOpt "" ["prove"] (updateArg "prove") "LEMMAPREFIX" + "Attempt to prove a lemma " , flagOpt "dfs" ["stop-on-trace"] (updateArg "stopOnTrace") "DFS|BFS|NONE" "How to search for traces (default DFS)" @@ -142,7 +152,7 @@ -- | Close a theory according to arguments. closeThy :: Arguments -> OpenTheory -> IO ClosedTheory closeThy as = - fmap (proveTheory prover . partialEvaluation) + fmap (proveTheory lemmaSelector prover . partialEvaluation) . closeTheory (maudePath as) -- FIXME: wf-check is at the wrong position here. Needs to be more -- fine-grained. @@ -163,11 +173,17 @@ noteWellformedness (checkWellformedness thy) thy + lemmaSelector :: Lemma p -> Bool + lemmaSelector lem = + any (`isPrefixOf` get lName lem) lemmaNames + where + lemmaNames = findArg "prove" as + -- replace all annotated sorrys with the configured autoprover. prover :: Prover - prover | argExists "addProofs" as = + prover | argExists "prove" as = replaceSorryProver $ runAutoProver $ constructAutoProver as - | otherwise = mempty + | otherwise = mempty -- | Construct an 'AutoProver' from the given arguments (--bound, -- --stop-on-trace). @@ -203,3 +219,31 @@ Just "none" -> CutNothing Just "bfs" -> CutBFS Just other -> error $ "unknown stop-on-trace method: " ++ other + + +------------------------------------------------------------------------------ +-- Message deduction variants cached in files +------------------------------------------------------------------------------ + +-- | The name of the intruder variants file. +intruderVariantsFile :: FilePath +intruderVariantsFile = "intruder_variants_dh.spthy" + +-- | Add the variants of the message deduction rule. Uses the cached version +-- of the @"intruder_variants_dh.spthy"@ file for the variants of the message +-- deduction rules for Diffie-Hellman exponentiation. +addMessageDeductionRuleVariants :: OpenTheory -> IO OpenTheory +addMessageDeductionRuleVariants thy0 + | enableDH msig = do + variantsFile <- getDataFileName intruderVariantsFile + ifM (doesFileExist variantsFile) + (do dhVariants <- parseIntruderRulesDH variantsFile + return $ addIntrRuleACs dhVariants thy + ) + (error $ "could not find intruder message deduction theory '" + ++ variantsFile ++ "'") + | otherwise = return thy + where + msig = get (sigpMaudeSig . thySignature) thy0 + rules = subtermIntruderRules msig ++ specialIntruderRules + thy = addIntrRuleACs rules thy0 diff --git a/src/Test/ParserTests.hs b/src/Test/ParserTests.hs new file mode 100644 --- /dev/null +++ b/src/Test/ParserTests.hs @@ -0,0 +1,92 @@ +-- | +-- Copyright : (c) 2012 Simon Meier +-- License : GPL v3 (see LICENSE) +-- +-- Maintainer : Simon Meier +-- +-- Unit tests for checking that all examples parse properly. +module Test.ParserTests ( + + testParseFile + , testParseDirectory + ) where + +import Test.HUnit + +import Control.Basics + +import System.Directory +import System.FilePath + +import Theory +import Theory.Text.Parser +import Theory.Text.Pretty (render) +import Main.TheoryLoader (addMessageDeductionRuleVariants) + +-- | Test wether a given file exists, can be parsed, and can still be parsed +-- after being pretty printed. +testParseFile :: Maybe (FilePath, Prover) + -- ^ Path to maude and prover for testing whether proof parsing + -- works properly. + -> FilePath + -- ^ File on which to test parsing (and proving) + -> Test +testParseFile optionalProver inpFile = TestLabel inpFile $ TestCase $ do + thyString <- readFile inpFile + thy0 <- parse "original file:" thyString + -- add proofs and pretty print closed theory, if desired + (thy, thyPretty) <- case optionalProver of + Nothing -> + return (thy0, prettyOpenTheory thy0) + Just (maudePath, prover) -> do + closedThy <- proveTheory (const True) prover <$> closeTheory maudePath thy0 + return $ ( normalizeTheory $ openTheory closedThy + , prettyClosedTheory closedThy) + thy' <- parse "pretty printed theory:" (render thyPretty) + unless (thy == thy') $ do + let (diff1, diff2) = + unzip $ dropWhile (uncurry (==)) $ zip (show thy) (show thy') + assertFailure $ unlines + [ "Original theory", "", render (prettyOpenTheory thy), "" + , "Pretty printed and parsed" , "", render (prettyOpenTheory thy'), "" + , "Original theory (diff)", "", indent diff1, "" + , "Pretty printed and parsed (diff)" , "", indent diff2, "", "DIFFER" + ] + return () + where + indent = unlines . map (' ' :) . lines + + parse msg str = case parseOpenTheoryString [] str of + Left err -> do assertFailure $ withLineNumbers $ indent $ show err + return (error "testParseFile: dead code") + Right thy -> normalizeTheory <$> addMessageDeductionRuleVariants thy + where + withLineNumbers err = + unlines $ zipWith (\i l -> nr (show i) ++ l) [(1::Int)..] ls + ++ ["", "Parse error when parsing the " ++ msg, err] + where + ls = lines str + n = length (show (length ls)) + nr i = replicate (1 + max 0 (n - length i)) ' ' ++ i ++ ": " + +-- | Create the test whether 'testParseFile' succeeds on all @*.spthy@ files +-- in a given directory and all its subdirectories of depth n. +testParseDirectory :: (FilePath -> Test) -- ^ Test creation function. + -> Int -- ^ Maximal depth of traversal. + -> FilePath -- ^ Starting directory. + -> IO [Test] +testParseDirectory mkTest n dir + | n < 0 = return [] + | otherwise = do + rawContents <- getDirectoryContents dir + let contents = [ dir content + | content <- rawContents + , content /= ".", content /= ".." ] + subDirs <- filterM doesDirectoryExist contents + innerTests <- mapM (testParseDirectory mkTest (n - 1)) subDirs + let tests = [ file + | file <- contents, takeExtension file == ".spthy" ] + mapM_ (putStrLn . (" peparing: " ++)) tests + return $ map mkTest tests ++ map TestList innerTests + + diff --git a/src/Theory.hs b/src/Theory.hs deleted file mode 100644 --- a/src/Theory.hs +++ /dev/null @@ -1,942 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Theory datatype and transformations on it. -module Theory ( - -- * Axioms - Axiom(..) - , axName - , axFormula - - -- * Lemmas - , LemmaAttribute(..) - , TraceQuantifier(..) - , Lemma - , lName - , lTraceQuantifier - , lFormula - , lAttributes - , lProof - , unprovenLemma - , skeletonLemma - - -- * Theories - , Theory(..) - , TheoryItem(..) - , thyName - , thySignature - , thyCache - , thyItems - , theoryRules - , theoryLemmas - , theoryAxioms - , addAxiom - , addLemma - , removeLemma - , lookupLemma - , addComment - , addStringComment - , addFormalComment - , cprRuleE - - -- ** Open theories - , OpenTheory - , defaultOpenTheory - , addProtoRule - , applyPartialEvaluation - , addIntrRuleACs - , normalizeTheory - - -- ** Closed theories - , ClosedTheory - , ClosedRuleCache(..) -- FIXME: this is only exported for the Binary instances - , closeTheory - , openTheory - - , ClosedProtoRule(..) - - , getLemmas - , getIntrVariants - , getProtoRuleEs - , getProofContext - , getClassifiedRules - , getInjectiveFactInsts - - , getCaseDistinction - - -- ** Proving - , ProofSkeleton - , proveTheory - - -- ** Lemma references - , lookupLemmaProof - , modifyLemmaProof - - -- * Pretty printing - , prettyFormalComment - , prettyLemmaName - , prettyAxiom - , prettyLemma - , prettyClosedTheory - , prettyOpenTheory - - , prettyClosedSummary - - , prettyIntruderVariants - , prettyTraceQuantifier - - -- * Convenience exports - , module Theory.Model - , module Theory.Proof - - ) where - -import Prelude hiding (id, (.)) - -import Data.Binary -import Data.DeriveTH -import Data.Foldable (Foldable, foldMap) -import Data.List -import Data.Maybe -import Data.Monoid (Sum(..)) -import qualified Data.Set as S -import Data.Traversable (Traversable, traverse) - -import Control.Basics -import Control.Category -import Control.DeepSeq -import Control.Monad.Reader -import qualified Control.Monad.State as MS -import Control.Parallel.Strategies - -import Extension.Data.Label hiding (get) -import qualified Extension.Data.Label as L - -import Theory.Model -import Theory.Proof -import Theory.Text.Pretty -import Theory.Tools.AbstractInterpretation -import Theory.Tools.InjectiveFactInstances -import Theory.Tools.LoopBreakers -import Theory.Tools.RuleVariants - ------------------------------------------------------------------------------- --- Specific proof types ------------------------------------------------------------------------------- - --- | Proof skeletons are used to represent proofs in open theories. -type ProofSkeleton = Proof () - --- | Convert a proof skeleton to an incremental proof without any sequent --- annotations. -skeletonToIncrementalProof :: ProofSkeleton -> IncrementalProof -skeletonToIncrementalProof = fmap (fmap (const Nothing)) - --- | Convert an incremental proof to a proof skeleton by dropping all --- annotations. -incrementalToSkeletonProof :: IncrementalProof -> ProofSkeleton -incrementalToSkeletonProof = fmap (fmap (const ())) - - ------------------------------------------------------------------------------- --- Commented sets of rewriting rules ------------------------------------------------------------------------------- - --- | A protocol rewriting rule modulo E together with its possible assertion --- soundness proof. -type OpenProtoRule = ProtoRuleE - --- | A closed proto rule lists its original rule modulo E, the corresponding --- variant modulo AC, and if required the assertion soundness proof. -data ClosedProtoRule = ClosedProtoRule - { _cprRuleE :: ProtoRuleE -- original rule modulo E - , _cprRuleAC :: ProtoRuleAC -- variant modulo AC - } - deriving( Eq, Ord, Show ) - -type OpenRuleCache = [IntrRuleAC] - -data ClosedRuleCache = ClosedRuleCache - { _crcRules :: ClassifiedRules - , _crcUntypedCaseDists :: [CaseDistinction] - , _crcTypedCaseDists :: [CaseDistinction] - , _crcInjectiveFactInsts :: S.Set FactTag - } - deriving( Eq, Ord, Show ) - - -$(mkLabels [''ClosedProtoRule, ''ClosedRuleCache]) - -instance HasRuleName ClosedProtoRule where - ruleName = ruleName . L.get cprRuleE - - --- Relation between open and closed rule sets ---------------------------------------------- - --- | All intruder rules of a set of classified rules. -intruderRules :: ClassifiedRules -> [IntrRuleAC] -intruderRules rules = do - Rule (IntrInfo i) ps cs as <- joinAllRules rules - return $ Rule i ps cs as - --- | Open a rule cache. Variants and precomputed case distinctions are dropped. -openRuleCache :: ClosedRuleCache -> OpenRuleCache -openRuleCache = intruderRules . L.get crcRules - --- | Open a protocol rule; i.e., drop variants and proof annotations. -openProtoRule :: ClosedProtoRule -> OpenProtoRule -openProtoRule = L.get cprRuleE - --- | Close a protocol rule; i.e., compute AC variant and typing assertion --- soundness sequent, if required. -closeProtoRule :: MaudeHandle -> OpenProtoRule -> ClosedProtoRule -closeProtoRule hnd ruE = ClosedProtoRule ruE (variantsProtoRule hnd ruE) --- | Close a rule cache. Hower, note that the --- requires case distinctions are not computed here. -closeRuleCache :: [LNGuarded] -- ^ Axioms to use. - -> [LNGuarded] -- ^ Typing lemmas to use. - -> SignatureWithMaude -- ^ Signature of theory. - -> [ClosedProtoRule] -- ^ Protocol rules with variants. - -> OpenRuleCache -- ^ Intruder rules modulo AC. - -> ClosedRuleCache -- ^ Cached rules and case distinctions. -closeRuleCache axioms typAsms sig protoRules intrRulesAC = - ClosedRuleCache - classifiedRules untypedCaseDists typedCaseDists injFactInstances - where - ctxt0 = ProofContext - sig classifiedRules injFactInstances UntypedCaseDist [] AvoidInduction - (error "closeRuleCache: trace quantifier should not matter here") - - -- inj fact instances - injFactInstances = - simpleInjectiveFactInstances $ L.get cprRuleE <$> protoRules - - -- precomputing the case distinctions: we make sure to only add safety - -- axioms. Otherwise, it wouldn't be sound to use the precomputed case - -- distinctions for properties proven using induction. - safetyAxioms = filter isSafetyFormula axioms - untypedCaseDists = precomputeCaseDistinctions ctxt0 safetyAxioms - typedCaseDists = refineWithTypingAsms typAsms ctxt0 untypedCaseDists - - -- classifying the rules - rulesAC = (fmap IntrInfo <$> intrRulesAC) <|> - ((fmap ProtoInfo . L.get cprRuleAC) <$> protoRules) - - anyOf ps = partition (\x -> any ($ x) ps) - - (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 - } - - ------------------------------------------------------------------------------- --- Axioms (Trace filters) ------------------------------------------------------------------------------- - --- | An axiom describes a property that must hold for all traces. Axioms are --- always used as lemmas in proofs. -data Axiom = Axiom - { _axName :: String - , _axFormula :: LNFormula - } - deriving( Eq, Ord, Show ) - -$(mkLabels [''Axiom]) - - ------------------------------------------------------------------------------- --- 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 - , _lTraceQuantifier :: TraceQuantifier - , _lFormula :: LNFormula - , _lAttributes :: [LemmaAttribute] - , _lProof :: p - } - deriving( Eq, Ord, Show ) - -$(mkLabels [''Lemma]) - - --- Instances ------------- - -instance Functor Lemma where - fmap f (Lemma n qua fm atts prf) = Lemma n qua fm atts (f prf) - -instance Foldable Lemma where - foldMap f = f . L.get lProof - -instance Traversable Lemma where - traverse f (Lemma n qua fm atts prf) = Lemma n qua fm atts <$> f prf - - --- Lemma queries ----------------------------------- - --- | Convert a trace quantifier to a sequent trace quantifier. -toSystemTraceQuantifier :: TraceQuantifier -> SystemTraceQuantifier -toSystemTraceQuantifier AllTraces = ExistsNoTrace -toSystemTraceQuantifier 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] -> TraceQuantifier -> LNFormula - -> Lemma ProofSkeleton -unprovenLemma name atts qua fm = Lemma name qua fm atts (unproven ()) - -skeletonLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> LNFormula - -> ProofSkeleton -> Lemma ProofSkeleton -skeletonLemma name atts qua fm = Lemma name qua fm atts - --- | The case-distinction kind allowed for a lemma -lemmaCaseDistKind :: Lemma p -> CaseDistKind -lemmaCaseDistKind lem - | TypingLemma `elem` L.get lAttributes lem = UntypedCaseDist - | otherwise = TypedCaseDist - - ------------------------------------------------------------------------------- --- Theories ------------------------------------------------------------------------------- - --- | A formal comment is a header together with the body of the comment. -type FormalComment = (String, String) - --- | A theory item built over the given rule type. -data TheoryItem r p = - RuleItem r - | LemmaItem (Lemma p) - | AxiomItem Axiom - | TextItem FormalComment - deriving( Show, Eq, Ord, Functor ) - - --- | A theory contains a single set of rewriting rules modeling a protocol --- and the lemmas that -data Theory sig c r p = Theory { - _thyName :: String - , _thySignature :: sig - , _thyCache :: c - , _thyItems :: [TheoryItem r p] - } - deriving( Eq, Ord, Show ) - -$(mkLabels [''Theory]) - --- | Open theories can be extended. Invariants: --- 1. Lemma names are unique. -type OpenTheory = - Theory SignaturePure [IntrRuleAC] OpenProtoRule ProofSkeleton - - --- | Closed theories can be proven. Invariants: --- 1. Lemma names are unique --- 2. All proof steps with annotated sequents are sound with respect to the --- closed rule set of the theory. --- 3. Maude is running under the given handle. -type ClosedTheory = - Theory SignatureWithMaude ClosedRuleCache ClosedProtoRule IncrementalProof - - - --- Shared theory modification functions ---------------------------------------- - --- | Fold a theory item. -foldTheoryItem - :: (r -> a) -> (Axiom -> a) -> (Lemma p -> a) -> (FormalComment -> a) - -> TheoryItem r p -> a -foldTheoryItem fRule fAxiom fLemma fText i = case i of - RuleItem ru -> fRule ru - LemmaItem lem -> fLemma lem - TextItem txt -> fText txt - AxiomItem ax -> fAxiom ax - --- | Map a theory item. -mapTheoryItem :: (r -> r') -> (p -> p') -> TheoryItem r p -> TheoryItem r' p' -mapTheoryItem f g = - foldTheoryItem (RuleItem . f) AxiomItem (LemmaItem . fmap g) TextItem - --- | All rules of a theory. -theoryRules :: Theory sig c r p -> [r] -theoryRules = - foldTheoryItem return (const []) (const []) (const []) <=< L.get thyItems - --- | All axioms of a theory. -theoryAxioms :: Theory sig c r p -> [Axiom] -theoryAxioms = - foldTheoryItem (const []) return (const []) (const []) <=< L.get thyItems - --- | All lemmas of a theory. -theoryLemmas :: Theory sig c r p -> [Lemma p] -theoryLemmas = - foldTheoryItem (const []) (const []) return (const []) <=< L.get thyItems - --- | Add a new axiom. Fails, if axiom with the same name exists. -addAxiom :: Axiom -> Theory sig c r p -> Maybe (Theory sig c r p) -addAxiom l thy = do - guard (isNothing $ lookupAxiom (L.get axName l) thy) - return $ modify thyItems (++ [AxiomItem l]) thy - --- | Add a new lemma. Fails, if a lemma with the same name exists. -addLemma :: Lemma p -> Theory sig c r p -> Maybe (Theory sig c r p) -addLemma l thy = do - guard (isNothing $ lookupLemma (L.get lName l) thy) - return $ modify thyItems (++ [LemmaItem l]) thy - --- | Remove a lemma by name. Fails, if the lemma does not exist. -removeLemma :: String -> Theory sig c r p -> Maybe (Theory sig c r p) -removeLemma lemmaName thy = do - _ <- lookupLemma lemmaName thy - return $ modify thyItems (concatMap fItem) thy - where - fItem = foldTheoryItem (return . RuleItem) - (return . AxiomItem) - check - (return . TextItem) - check l = do guard (L.get lName l /= lemmaName); return (LemmaItem l) - --- | Find the axiom with the given name. -lookupAxiom :: String -> Theory sig c r p -> Maybe Axiom -lookupAxiom name = find ((name ==) . L.get axName) . theoryAxioms - --- | Find the lemma with the given name. -lookupLemma :: String -> Theory sig c r p -> Maybe (Lemma p) -lookupLemma name = find ((name ==) . L.get lName) . theoryLemmas - --- | Add a comment to the theory. -addComment :: Doc -> Theory sig c r p -> Theory sig c r p -addComment c = modify thyItems (++ [TextItem ("", render c)]) - --- | Add a comment represented as a string to the theory. -addStringComment :: String -> Theory sig c r p -> Theory sig c r p -addStringComment = addComment . vcat . map text . lines - -addFormalComment :: FormalComment -> Theory sig c r p -> Theory sig c r p -addFormalComment c = modify thyItems (++ [TextItem c]) - - ------------------------------------------------------------------------------- --- Open theory construction / modification ------------------------------------------------------------------------------- - --- | Default theory -defaultOpenTheory :: OpenTheory -defaultOpenTheory = Theory "default" emptySignaturePure [] [] - --- | Open a theory by dropping the closed world assumption and values whose --- soundness dependens on it. -openTheory :: ClosedTheory -> OpenTheory -openTheory (Theory n sig c items) = - Theory n (toSignaturePure sig) (openRuleCache c) - (map (mapTheoryItem openProtoRule incrementalToSkeletonProof) items) - --- | Find the open protocol rule with the given name. -lookupOpenProtoRule :: ProtoRuleName -> OpenTheory -> Maybe OpenProtoRule -lookupOpenProtoRule name = - find ((name ==) . L.get rInfo) . theoryRules - --- | Add a new protocol rules. Fails, if a protocol rule with the same name --- exists. -addProtoRule :: ProtoRuleE -> OpenTheory -> Maybe OpenTheory -addProtoRule ruE thy = do - guard (maybe True ((ruE ==)) $ - lookupOpenProtoRule (L.get rInfo ruE) thy) - return $ modify thyItems (++ [RuleItem ruE]) thy - --- | Add intruder proof rules. -addIntrRuleACs :: [IntrRuleAC] -> OpenTheory -> OpenTheory -addIntrRuleACs rs' = modify (thyCache) (\rs -> nub $ rs ++ rs') - --- | Normalize the theory representation such that they remain semantically --- equivalent. Use this function when you want to compare two theories (quite --- strictly) for semantic equality; e.g., when testing the parser. -normalizeTheory :: OpenTheory -> OpenTheory -normalizeTheory = - L.modify thyCache sort - . L.modify thyItems (\items -> do - item <- items - return $ case item of - LemmaItem lem -> - LemmaItem $ L.modify lProof stripProofAnnotations $ lem - RuleItem _ -> item - TextItem _ -> item - AxiomItem _ -> item) - where - stripProofAnnotations :: ProofSkeleton -> ProofSkeleton - stripProofAnnotations = fmap stripProofStepAnnotations - stripProofStepAnnotations (ProofStep method ()) = - ProofStep (case method of - Sorry _ -> Sorry Nothing - Contradiction _ -> Contradiction Nothing - _ -> method) - () - - ------------------------------------------------------------------------------- --- Closed theory querying / construction / modification ------------------------------------------------------------------------------- - --- querying ------------ - --- | All lemmas. -getLemmas :: ClosedTheory -> [Lemma IncrementalProof] -getLemmas = theoryLemmas - --- | The variants of the intruder rules. -getIntrVariants :: ClosedTheory -> [IntrRuleAC] -getIntrVariants = intruderRules . L.get (crcRules . thyCache) - --- | All protocol rules modulo E. -getProtoRuleEs :: ClosedTheory -> [ProtoRuleE] -getProtoRuleEs = map openProtoRule . theoryRules - --- | Get the proof context for a lemma of the closed theory. -getProofContext :: Lemma a -> ClosedTheory -> ProofContext -getProofContext l thy = ProofContext - ( L.get thySignature thy) - ( L.get (crcRules . thyCache) thy) - ( L.get (crcInjectiveFactInsts . thyCache) thy) - kind - ( L.get (cases . thyCache) thy) - inductionHint - (toSystemTraceQuantifier $ L.get lTraceQuantifier l) - where - kind = lemmaCaseDistKind l - cases = case kind of UntypedCaseDist -> crcUntypedCaseDists - TypedCaseDist -> crcTypedCaseDists - inductionHint - | any (`elem` [TypingLemma, InvariantLemma]) (L.get lAttributes l) = UseInduction - | otherwise = AvoidInduction - --- | The facts with injective instances in this theory -getInjectiveFactInsts :: ClosedTheory -> S.Set FactTag -getInjectiveFactInsts = L.get (crcInjectiveFactInsts . thyCache) - --- | The classified set of rules modulo AC in this theory. -getClassifiedRules :: ClosedTheory -> ClassifiedRules -getClassifiedRules = L.get (crcRules . thyCache) - --- | The precomputed case distinctions. -getCaseDistinction :: CaseDistKind -> ClosedTheory -> [CaseDistinction] -getCaseDistinction UntypedCaseDist = L.get (crcUntypedCaseDists . thyCache) -getCaseDistinction TypedCaseDist = L.get (crcTypedCaseDists . thyCache) - - --- 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 checking the proof --- skeletons and caching AC variants as well as precomputed case distinctions. --- --- This function initializes the relation to the Maude process with the --- correct signature. This is the right place to do that because in a closed --- theory the signature may not change any longer. -closeTheory :: FilePath -- ^ Path to the Maude executable. - -> OpenTheory - -> IO ClosedTheory -closeTheory maudePath thy0 = do - sig <- toSignatureWithMaude maudePath $ L.get thySignature thy0 - return $ closeTheoryWithMaude sig thy0 - --- | 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 checkProof $ Theory (L.get thyName thy0) sig cache items - where - cache = closeRuleCache axioms typAsms sig rules (L.get thyCache thy0) - checkProof = checkAndExtendProver (sorryProver Nothing) - - -- Maude / Signature handle - hnd = L.get sigmMaudeHandle sig - - -- Close all theory items: in parallel (especially useful for variants) - -- - -- NOTE that 'rdeepseq' is OK here, as the proof has not yet been checked - -- and therefore no constraint systems will be unnecessarily cached. - (items, _solveRel, _breakers) = (`runReader` hnd) $ addSolvingLoopBreakers - ((closeTheoryItem <$> L.get thyItems thy0) `using` parList rdeepseq) - closeTheoryItem = foldTheoryItem - (RuleItem . closeProtoRule hnd) - AxiomItem - (LemmaItem . fmap skeletonToIncrementalProof) - TextItem - - -- extract typing axioms and lemmas - axioms = do AxiomItem ax <- items - return $ formulaToGuarded_ $ L.get axFormula ax - typAsms = do LemmaItem lem <- items - guard (isTypingLemma lem) - return $ formulaToGuarded_ $ L.get lFormula lem - - -- 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 -------------------- - --- | 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. -proveTheory :: Prover -> ClosedTheory -> ClosedTheory -proveTheory prover thy = - modify thyItems ((`MS.evalState` []) . mapM prove) thy - where - prove item = case item of - LemmaItem l0 -> do l <- MS.gets (LemmaItem . proveLemma l0) - MS.modify (l :) - return l - _ -> do return item - - proveLemma lem preItems = - modify lProof add lem - where - ctxt = getProofContext lem thy - sys = mkSystem ctxt (theoryAxioms thy) preItems $ L.get lFormula lem - add prf = fromMaybe prf $ runProver prover ctxt 0 sys prf - --- | Construct a constraint system for verifying the given formula. -mkSystem :: ProofContext -> [Axiom] -> [TheoryItem r p] - -> LNFormula -> System -mkSystem ctxt axioms previousItems = - -- Note that it is OK to add reusable lemmas directly to the system, as - -- they do not change the considered set of traces. This is the key - -- difference between lemmas and axioms. - addLemmas - . formulaToSystem (map (formulaToGuarded_ . L.get axFormula) axioms) - (L.get pcCaseDistKind ctxt) - (L.get pcTraceQuantifier ctxt) - where - addLemmas sys = - insertLemmas (gatherReusableLemmas $ L.get sCaseDistKind sys) sys - - gatherReusableLemmas kind = do - LemmaItem lem <- previousItems - guard $ lemmaCaseDistKind lem <= kind - && ReuseLemma `elem` L.get lAttributes lem - && AllTraces == L.get lTraceQuantifier lem - return $ formulaToGuarded_ $ L.get lFormula lem - - ------------------------------------------------------------------------------- --- References to lemmas ------------------------------------------------------------------------------- - --- | Lemmas are referenced by their name. -type LemmaRef = String - --- | Resolve a path in a theory. -lookupLemmaProof :: LemmaRef -> ClosedTheory -> Maybe IncrementalProof -lookupLemmaProof name thy = L.get lProof <$> lookupLemma name thy - --- | Modify the proof at the given lemma ref, if there is one. Fails if the --- path is not present or if the prover fails. -modifyLemmaProof :: Prover -> LemmaRef -> ClosedTheory -> Maybe ClosedTheory -modifyLemmaProof prover name thy = - modA thyItems changeItems thy - where - findLemma (LemmaItem lem) = name == L.get lName lem - findLemma _ = False - - change preItems (LemmaItem lem) = do - let ctxt = getProofContext lem thy - sys = mkSystem ctxt (theoryAxioms thy) preItems $ L.get lFormula lem - lem' <- modA lProof (runProver prover ctxt 0 sys) lem - return $ LemmaItem lem' - change _ _ = error "LemmaProof: change: impossible" - - changeItems items = case break findLemma items of - (pre, i:post) -> do - i' <- change pre i - return $ pre ++ i':post - (_, []) -> Nothing - - ------------------------------------------------------------------------------- --- Pretty printing ------------------------------------------------------------------------------- - --- | Pretty print a formal comment -prettyFormalComment :: HighlightDocument d => String -> String -> d -prettyFormalComment "" body = multiComment_ [body] -prettyFormalComment header body = text $ header ++ "{*" ++ body ++ "*}" - --- | Pretty print a theory. -prettyTheory :: HighlightDocument d - => (sig -> d) -> (c -> d) -> (r -> d) -> (p -> d) - -> Theory sig c r p -> d -prettyTheory ppSig ppCache ppRule ppPrf thy = vsep $ - [ kwTheoryHeader $ text $ L.get thyName thy - , lineComment_ "Function signature and definition of the equational theory E" - , ppSig $ L.get thySignature thy - , ppCache $ L.get thyCache thy - ] ++ - parMap rdeepseq ppItem (L.get thyItems thy) ++ - [ kwEnd ] - where - ppItem = foldTheoryItem - ppRule prettyAxiom (prettyLemma ppPrf) (uncurry prettyFormalComment) - --- | Pretty print the lemma name together with its attributes. -prettyLemmaName :: HighlightDocument d => Lemma p -> d -prettyLemmaName l = case L.get lAttributes l of - [] -> text (L.get lName l) - as -> text (L.get lName l) <-> - (brackets $ fsep $ punctuate comma $ map prettyLemmaAttribute as) - where - prettyLemmaAttribute TypingLemma = text "typing" - prettyLemmaAttribute ReuseLemma = text "reuse" - prettyLemmaAttribute InvariantLemma = text "use_induction" - --- | Pretty print an axiom. -prettyAxiom :: HighlightDocument d => Axiom -> d -prettyAxiom ax = - kwAxiom <-> text (L.get axName ax) <> colon $-$ - (nest 2 $ doubleQuotes $ prettyLNFormula $ L.get axFormula ax) $-$ - (nest 2 $ if safety then lineComment_ "safety formula" else emptyDoc) - where - safety = isSafetyFormula $ formulaToGuarded_ $ L.get axFormula ax - --- | Pretty print a lemma. -prettyLemma :: HighlightDocument d => (p -> d) -> Lemma p -> d -prettyLemma ppPrf lem = - kwLemma <-> prettyLemmaName lem <> colon $-$ - (nest 2 $ - sep [ prettyTraceQuantifier $ L.get lTraceQuantifier lem - , doubleQuotes $ prettyLNFormula $ L.get lFormula lem - ] - ) - $-$ - ppLNFormulaGuarded (L.get lFormula lem) - $-$ - ppPrf (L.get lProof lem) - where - ppLNFormulaGuarded fm = case formulaToGuarded fm of - Left err -> multiComment $ - text "conversion to guarded formula failed:" $$ - nest 2 err - Right gf -> case toSystemTraceQuantifier $ L.get lTraceQuantifier lem of - ExistsNoTrace -> multiComment - ( text "guarded formula characterizing all counter-examples:" $-$ - doubleQuotes (prettyGuarded (gnot gf)) ) - ExistsSomeTrace -> multiComment - ( text "guarded formula characterizing all satisfying traces:" $-$ - doubleQuotes (prettyGuarded gf) ) - - --- | Pretty-print a non-empty bunch of intruder rules. -prettyIntruderVariants :: HighlightDocument d => [IntrRuleAC] -> d -prettyIntruderVariants vs = vcat . intersperse (text "") $ map prettyIntrRuleAC vs - -{- --- | Pretty-print the intruder variants section. -prettyIntrVariantsSection :: HighlightDocument d => [IntrRuleAC] -> d -prettyIntrVariantsSection rules = - prettyFormalComment "section" " Finite Variants of the Intruder Rules " $--$ - nest 1 (prettyIntruderVariants rules) --} - --- | Pretty print an open rule together with its assertion soundness proof. -prettyOpenProtoRule :: HighlightDocument d => OpenProtoRule -> d -prettyOpenProtoRule = prettyProtoRuleE - -prettyIncrementalProof :: HighlightDocument d => IncrementalProof -> d -prettyIncrementalProof = prettyProofWith ppStep (const id) - where - ppStep step = sep - [ prettyProofMethod (psMethod step) - , if isNothing (psInfo step) then multiComment_ ["unannotated"] - else emptyDoc - ] - --- | Pretty print an closed rule. -prettyClosedProtoRule :: HighlightDocument d => ClosedProtoRule -> d -prettyClosedProtoRule cru = - (prettyProtoRuleE ruE) $--$ - (nest 2 $ prettyLoopBreakers (L.get rInfo ruAC) $-$ ppRuleAC) - where - 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 -prettyOpenTheory = - prettyTheory prettySignaturePure - (const emptyDoc) prettyOpenProtoRule prettyProof - -- prettyIntrVariantsSection prettyOpenProtoRule prettyProof - --- | Pretty print a closed theory. -prettyClosedTheory :: HighlightDocument d => ClosedTheory -> d -prettyClosedTheory thy = - prettyTheory prettySignatureWithMaude - ppInjectiveFactInsts - -- (prettyIntrVariantsSection . intruderRules . L.get crcRules) - prettyClosedProtoRule - prettyIncrementalProof - thy - where - ppInjectiveFactInsts crc = - case S.toList $ L.get crcInjectiveFactInsts crc of - [] -> emptyDoc - tags -> lineComment $ sep - [ text "looping facts with injective instances:" - , nest 2 $ fsepList (text . showFactTagArity) tags ] - -prettyClosedSummary :: Document d => ClosedTheory -> d -prettyClosedSummary thy = - vcat lemmaSummaries - where - lemmaSummaries = do - LemmaItem lem <- L.get thyItems thy - -- Note that here we are relying on the invariant that all proof steps - -- with a 'Just' annotation follow from the application of - -- 'execProofMethod' to their parent and are valid in the sense that - -- the application of 'execProofMethod' to their method and constraint - -- system is guaranteed to succeed. - -- - -- This is guaranteed initially by 'closeTheory' and is (must be) - -- maintained by the provers being applied to the theory using - -- 'modifyLemmaProof' or 'proveTheory'. Note that we could check the - -- proof right before computing its status. This is however quite - -- expensive, as it requires recomputing all intermediate constraint - -- systems. - -- - -- TODO: The whole consruction seems a bit hacky. Think of a more - -- principled constrution with better correctness guarantees. - let (status, Sum siz) = foldProof proofStepSummary $ L.get lProof lem - quantifier = (toSystemTraceQuantifier $ 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 ''Axiom) -$( derive makeBinary ''Lemma) -$( derive makeBinary ''ClosedProtoRule) -$( derive makeBinary ''ClosedRuleCache) -$( derive makeBinary ''Theory) - -$( derive makeNFData ''TheoryItem) -$( derive makeNFData ''LemmaAttribute) -$( derive makeNFData ''TraceQuantifier) -$( derive makeNFData ''Axiom) -$( derive makeNFData ''Lemma) -$( derive makeNFData ''ClosedProtoRule) -$( derive makeNFData ''ClosedRuleCache) -$( derive makeNFData ''Theory) - diff --git a/src/Theory/Constraint/Solver.hs b/src/Theory/Constraint/Solver.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- The public interface of the constraint solver, which implements all --- constraint reduction rules and together with a rule application heuristic. -module Theory.Constraint.Solver ( - - -- * Constraint systems - module Theory.Constraint.System - - -- * Proof contexts - -- | The proof context captures all relevant information about the context - -- in which we are using the constraint solver. These are things like the - -- signature of the message theory, the multiset rewriting rules of the - -- protocol, the available precomputed case distinctions, whether induction - -- should be applied or not, whether typed or untyped case distinctions are - -- used, and whether we are looking for the existence of a trace or proving - -- the absence of any trace satisfying the constraint system. - , ProofContext(..) - , pcSignature - , pcRules - , pcCaseDists - , pcUseInduction - , pcCaseDistKind - , pcTraceQuantifier - , pcInjectiveFactInsts - - , InductionHint(..) - - , ClassifiedRules(..) - , joinAllRules - , crProtocol - , crConstruct - , crDestruct - - -- * Constraint reduction rules - - -- ** Contradictions - -- | All rules that reduce a constraint system to the empty set of - -- constraint systems. The 'Contradiction' datatype stores the information - -- about the contradiction for later display to the user. - , Contradiction - , contradictions - - -- ** Precomputed case distinctions - -- | For better speed, we precompute case distinctions. This is especially - -- important for getting rid of all chain constraints before actually - -- starting to verify security properties. - , CaseDistinction - , cdGoal - , cdCases - - , precomputeCaseDistinctions - , refineWithTypingAsms - , unsolvedChainConstraints - - -- * Proof methods - -- | Proof methods are the external to the constraint solver. They allow its - -- small step execution. This module also provides the heuristics for - -- selecting the best proof method to apply to a constraint system. - , module Theory.Constraint.Solver.ProofMethod - - -- ** Convenience export - , module Logic.Connectives - - ) where - -import Logic.Connectives -import Theory.Constraint.Solver.CaseDistinctions -import Theory.Constraint.Solver.Contradictions -import Theory.Constraint.Solver.ProofMethod -import Theory.Constraint.Solver.Types -import Theory.Constraint.System - - diff --git a/src/Theory/Constraint/Solver/CaseDistinctions.hs b/src/Theory/Constraint/Solver/CaseDistinctions.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver/CaseDistinctions.hs +++ /dev/null @@ -1,318 +0,0 @@ --- | --- Copyright : (c) 2011,2012 Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Big-step proofs using case distinctions on the possible sources of a fact. -module Theory.Constraint.Solver.CaseDistinctions ( - -- * Precomputed case distinctions - - -- ** Queries - unsolvedChainConstraints - - -- ** Construction - , precomputeCaseDistinctions - , refineWithTypingAsms - - -- ** Application - , solveWithCaseDistinction - - ) where - -import Prelude hiding (id, (.)) -import Safe - -import Data.Foldable (asum) -import qualified Data.Map as M -import Data.Maybe (isJust) -import qualified Data.Set as S - -import Control.Basics -import Control.Category -import Control.Monad.Disj -import Control.Monad.Reader -import Control.Monad.State (gets) -import Control.Parallel.Strategies - -import Text.PrettyPrint.Highlight - -import Extension.Data.Label -import Extension.Prelude - -import Theory.Constraint.Solver.Contradictions (contradictorySystem) -import Theory.Constraint.Solver.Goals -import Theory.Constraint.Solver.Reduction -import Theory.Constraint.Solver.Simplify -import Theory.Constraint.Solver.Types -import Theory.Constraint.System -import Theory.Model - - ------------------------------------------------------------------------------- --- Precomputing case distinctions ------------------------------------------------------------------------------- - --- | The number of remaining chain constraints of each case. -unsolvedChainConstraints :: CaseDistinction -> [Int] -unsolvedChainConstraints = - map (length . unsolvedChains . snd) . getDisj . get cdCases - - --- Construction ---------------- - --- | The initial case distinction if the given goal is required and the --- given typing assumptions are justified. -initialCaseDistinction - :: ProofContext - -> [LNGuarded] -- ^ Axioms. - -> Goal - -> CaseDistinction -initialCaseDistinction ctxt axioms goal = - CaseDistinction goal cases - where - polish ((name, se), _) = ([name], se) - se0 = insertLemmas axioms $ emptySystem UntypedCaseDist - cases = fmap polish $ - runReduction instantiate ctxt se0 (avoid (goal, se0)) - instantiate = do - insertGoal goal False - solveGoal goal - --- | Refine a source case distinction by applying the additional proof step. -refineCaseDistinction - :: ProofContext - -> Reduction (a, [String]) -- proof step with result and path extension - -> CaseDistinction - -> ([a], CaseDistinction) -refineCaseDistinction ctxt proofStep th = - ( map fst $ getDisj refinement - , set cdCases (snd <$> refinement) th ) - where - fs = avoid th - refinement = do - (names, se) <- get cdCases th - ((x, names'), se') <- fst <$> runReduction proofStep ctxt se fs - return (x, (combine names names', se')) - - -- Combine names such that the coerce rule is blended out. - combine [] ns' = ns' - combine ("coerce":ns) ns' = combine ns ns' - combine (n :_) _ = [n] - --- | Solves all chain and splitting goals as well as all premise goals solvable --- with one of the given precomputed requires case distinction theorems, while --- repeatedly simplifying the proof state. --- --- Returns the names of the steps applied. -solveAllSafeGoals :: [CaseDistinction] -> Reduction [String] -solveAllSafeGoals ths = - solve [] - where - safeGoal _ (_, (_, LoopBreaker)) = False - safeGoal doSplit (goal, _ ) = - case goal of - ChainG _ _ -> True - ActionG _ fa -> not (isKUFact fa) - PremiseG _ fa -> not (isKUFact fa) - DisjG _ -> doSplit - -- Uncomment to get more extensive case splitting - -- SplitG _ -> doSplit - SplitG _ -> False - - usefulGoal (_, (_, Useful)) = True - usefulGoal _ = False - - solve caseNames = do - simplifySystem - ctxt <- ask - contradictoryIf =<< gets (contradictorySystem ctxt) - goals <- gets openGoals - chains <- gets unsolvedChains - -- try to either solve a safe goal or use one of the precomputed case - -- distinctions - let noChainGoals = null [ () | (ChainG _ _, _) <- goals ] - -- we perform equation splits, if there is a chain goal starting - -- from a message variable; i.e., a chain constraint that is no - -- open goal. - splitAllowed = noChainGoals && not (null chains) - safeGoals = fst <$> filter (safeGoal splitAllowed) goals - usefulGoals = fst <$> filter usefulGoal goals - nextStep = - ((fmap return . solveGoal) <$> headMay safeGoals) <|> - (asum $ map (solveWithCaseDistinction ctxt ths) usefulGoals) - case nextStep of - Nothing -> return $ caseNames - Just step -> solve . (caseNames ++) =<< step - - ------------------------------------------------------------------------------- --- Applying precomputed case distinctions ------------------------------------------------------------------------------- - --- | Match a precomputed 'CaseDistinction' to a goal. -matchToGoal - :: ProofContext -- ^ Proof context used for refining the case distinction. - -> CaseDistinction -- ^ Case distinction to use. - -> Goal -- ^ Goal to match - -> Maybe (Reduction [String]) - -- ^ A constraint reduction step to apply the resulting case distinction. - -- Note that this step assumes that the theorem has been imported using - -- 'someInst' into the context that this reduction is executed in. - -- - -- FIXME: This is a mess. Factor code such that this inter-dependency - -- between 'applyCaseDistinction' and 'matchToGoal' goes away. -matchToGoal ctxt th goalTerm = - case (goalTerm, get cdGoal th) of - ( PremiseG (iTerm, premIdxTerm) faTerm - ,PremiseG pPat@(iPat, _ ) faPat ) -> - let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in - case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of - [] -> Nothing - subst:_ -> Just $ genericApply subst $ - -- add the missing edge to each case of the theorem - modify sEdges (substNodePrem pPat (iPat, premIdxTerm)) - - (ActionG iTerm faTerm, ActionG iPat faPat) -> - let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in - case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of - [] -> Nothing - subst:_ -> Just $ genericApply subst id - - -- No other matches possible, as we only precompute case distinctions for - -- premises and KU-actions. - _ -> Nothing - where - genericApply subst systemModifier = do - void (solveSubstEqs SplitNow subst) - (names, sysTh) <- disjunctionOfList $ getDisj $ get cdCases th - conjoinSystem (systemModifier sysTh) - return names - - substNodePrem from to = S.map - (\ e@(Edge c p) -> if p == from then Edge c to else e) - --- | Try to solve a premise goal or 'Ded' action using the first precomputed --- case distinction with a matching premise. -solveWithCaseDistinction :: ProofContext - -> [CaseDistinction] - -> Goal - -> Maybe (Reduction [String]) -solveWithCaseDistinction hnd ths goal = do - -- goal <- toBigStepGoal goal0 - asum [ applyCaseDistinction hnd th goal | th <- ths ] - --- | Apply a precomputed case distinction theorem to a required fact. -applyCaseDistinction :: ProofContext - -> CaseDistinction -- ^ Case distinction theorem. - -> Goal -- ^ Required goal - -> Maybe (Reduction [String]) -applyCaseDistinction ctxt th goal - | isJust $ matchToGoal ctxt th goal = Just $ do - markGoalAsSolved "precomputed" goal - thRenamed <- rename th - fromJustNote "applyCaseDistinction: impossible" $ - matchToGoal ctxt thRenamed goal - - | otherwise = Nothing - --- | Saturate the case distinctions with respect to each other such that no --- additional splitting is introduced; i.e., only rules with a single or no --- conclusion are used for the saturation. -saturateCaseDistinctions - :: ProofContext -> [CaseDistinction] -> [CaseDistinction] -saturateCaseDistinctions ctxt = - go - where - go ths = - if any or (changes `using` parList rdeepseq) - then go ths' - else ths' - where - (changes, ths') = unzip $ map (refineCaseDistinction ctxt solver) ths - goodTh th = length (getDisj (get cdCases th)) <= 1 - solver = do names <- solveAllSafeGoals (filter goodTh ths) - return (not $ null names, names) - --- | Precompute a saturated set of case distinctions. -precomputeCaseDistinctions - :: ProofContext - -> [LNGuarded] -- ^ Axioms. - -> [CaseDistinction] -precomputeCaseDistinctions ctxt axioms = - map cleanupCaseNames $ saturateCaseDistinctions ctxt rawCaseDists - where - cleanupCaseNames = modify cdCases $ fmap $ first $ - filter (not . null) - . map (filter (`elem` '_' : ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'])) - - rawCaseDists = - initialCaseDistinction ctxt axioms <$> (protoGoals ++ msgGoals) - - -- construct case distinction starting from facts from non-special rules - protoGoals = someProtoGoal <$> absProtoFacts - msgGoals = someKUGoal <$> absMsgFacts - - getProtoFact (Fact KUFact _ ) = mzero - getProtoFact (Fact KDFact _ ) = mzero - getProtoFact fa = return fa - - absFact (Fact tag ts) = (tag, length ts) - - nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..fromIntegral n] ] - - someProtoGoal :: (FactTag, Int) -> Goal - someProtoGoal (tag, arity) = - PremiseG (someNodeId, PremIdx 0) (Fact tag (nMsgVars arity)) - - someKUGoal :: LNTerm -> Goal - someKUGoal m = ActionG someNodeId (kuFact m) - - someNodeId = LVar "i" LSortNode 0 - - -- FIXME: Also use facts from proof context. - rules = get pcRules ctxt - absProtoFacts = sortednub $ do - 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]) - return fa - - absMsgFacts :: [LNTerm] - absMsgFacts = asum $ sortednub $ - [ do return $ lit $ Var (LVar "t" LSortFresh 1) - - , [ 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 --- assumptions. -refineWithTypingAsms - :: [LNGuarded] -- ^ Typing assumptions to use. - -> ProofContext -- ^ Proof context to use. - -> [CaseDistinction] -- ^ Original, untyped case distinctions. - -> [CaseDistinction] -- ^ Refined, typed case distinctions. -refineWithTypingAsms assumptions ctxt cases0 = - fmap (modifySystems removeFormulas) $ - saturateCaseDistinctions ctxt $ - modifySystems updateSystem <$> cases0 - where - modifySystems = modify cdCases . fmap . second - updateSystem se = - modify sFormulas (S.union (S.fromList assumptions)) $ - set sCaseDistKind TypedCaseDist $ se - removeFormulas = - modify sGoals (M.filterWithKey isNoDisjGoal) - . set sFormulas S.empty - . set sSolvedFormulas S.empty - - isNoDisjGoal (DisjG _) _ = False - isNoDisjGoal _ _ = True - - - diff --git a/src/Theory/Constraint/Solver/Contradictions.hs b/src/Theory/Constraint/Solver/Contradictions.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver/Contradictions.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- This is the public interface for constructing and deconstructing constraint --- systems. The interface for performing constraint solving provided by --- "Theory.Constraint.Solver". -module Theory.Constraint.Solver.Contradictions ( - - -- * Contradictory constraint systems - Contradiction(..) - , substCreatesNonNormalTerms - , contradictions - , contradictorySystem - - -- ** Pretty-printing - , prettyContradiction - - ) where - -import Prelude hiding (id, (.)) - -import Data.Binary -import qualified Data.DAG.Simple as D (cyclic, reachableSet) -import Data.DeriveTH -import qualified Data.Foldable as F -import Data.List -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Monoid -import qualified Data.Set as S -import Safe (headMay) - -import Control.Basics -import Control.Category -import Control.DeepSeq -import Control.Monad.Reader - -import qualified Extension.Data.Label as L -import Extension.Prelude - -import Theory.Constraint.Solver.Types -import Theory.Constraint.System -import Theory.Model -import Theory.Text.Pretty - -import Term.Rewriting.Norm (maybeNotNfSubterms, nf') - - ------------------------------------------------------------------------------- --- Contradictions ------------------------------------------------------------------------------- - --- | Reasons why a constraint 'System' can be contradictory. -data Contradiction = - Cyclic -- ^ The paths are cyclic. - | NonNormalTerms -- ^ Has terms that are not in normal form. - -- | NonLastNode -- ^ Has a non-silent node after the last node. - | ForbiddenExp -- ^ Forbidden Exp-down rule instance - | NonInjectiveFactInstance (NodeId, NodeId, NodeId) - -- ^ Contradicts that certain facts have unique instances. - | IncompatibleEqs -- ^ Incompatible equalities. - | FormulasFalse -- ^ False in formulas - | SuperfluousLearn LNTerm NodeId -- ^ A term is derived both before and after a learn - | NodeAfterLast (NodeId, NodeId) -- ^ There is a node after the last node. - deriving( Eq, Ord, Show ) - - --- | 'True' if the constraint system is contradictory. -contradictorySystem :: ProofContext -> System -> Bool -contradictorySystem ctxt = not . null . contradictions ctxt - --- | All CR-rules reducing a constraint system to *⟂* represented as a list of --- trivial contradictions. Note that some constraint systems are also removed --- because they have no unifier. This is part of unification. Note also that --- *S_{¬,@}* is handled as part of *S_∀*. -contradictions :: ProofContext -> System -> [Contradiction] -contradictions ctxt sys = F.asum - -- CR-rule ** - [ guard (D.cyclic $ rawLessRel sys) *> pure Cyclic - -- CR-rule *N1* - , guard (hasNonNormalTerms sig sys) *> pure NonNormalTerms - -- CR-rule *N7* - , guard (hasForbiddenExp sys) *> pure ForbiddenExp - -- CR-rules *S_≐* and *S_≈* are implemented via the equation store - , guard (eqsIsFalse $ L.get sEqStore sys) *> pure IncompatibleEqs - -- CR-rules *S_⟂*, *S_{¬,last,1}*, *S_{¬,≐}*, *S_{¬,≈}* - , guard (S.member gfalse $ L.get sFormulas sys) *> pure FormulasFalse - ] - ++ - -- This rule is not yet documented. It removes constraint systems that - -- require a unique fact to be present in the system state more than once. - -- Unique facts are declared as part of the specification of the rule - -- system. - (NonInjectiveFactInstance <$> nonInjectiveFactInstances ctxt sys) - ++ - -- TODO: Document corresponding constratint reduction rule. - (NodeAfterLast <$> nodesAfterLast sys) - where - sig = L.get pcSignature ctxt - --- | True iff there are terms in the node constraints that are not in normal form wrt. --- to 'Term.Rewriting.Norm.norm' (DH/AC). -hasNonNormalTerms :: SignatureWithMaude -> System -> Bool -hasNonNormalTerms sig se = - any (not . (`runReader` hnd) . nf') (maybeNonNormalTerms hnd se) - where hnd = L.get sigmMaudeHandle sig - --- | Returns all (sub)terms of node constraints that may be not in normal form. -maybeNonNormalTerms :: MaudeHandle -> System -> [LNTerm] -maybeNonNormalTerms hnd se = - sortednub . concatMap getTerms . M.elems . L.get sNodes $ se - where getTerms (Rule _ ps cs as) = do - f <- ps++cs++as - t <- factTerms f - maybeNotNfSubterms (mhMaudeSig hnd) t - -substCreatesNonNormalTerms :: MaudeHandle -> System -> 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 :: System -> Bool -hasForbiddenExp se = - any (isForbiddenExp) $ M.elems $ L.get sNodes se - --- | @isForbiddenExp ru@ returns @True@ if @ru@ is not allowed in --- a normal dependency graph. --- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]] --- [Fact KDFact [expTagToTerm IsExp, Exp p1 (Mult x2 x3)]] []) --- > False --- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]] --- [Fact KDFact [expTagToTerm IsExp, Exp p1 x2]] []) --- > True -isForbiddenExp :: Rule a -> Bool -isForbiddenExp ru = fromMaybe False $ do - [p1,p2] <- return $ L.get rPrems ru - [conc] <- return $ L.get rConcs ru - (DnK, viewTerm2 -> FExp _ _) <- kFactView p1 - (UpK, b ) <- kFactView p2 - (DnK, viewTerm2 -> FExp g c) <- kFactView conc - - -- For a forbidden exp the following conditions must hold: g must be of - -- sort 'pub' and the required inputs for c are already required by b - return $ sortOfLNTerm g == LSortPub - && (inputTerms c \\ inputTerms b == []) - - --- | Compute all contradictions to injective fact instances. --- --- Formally, they are computed as follows. Let 'f' be a fact symbol with --- injective instances. Let i, j, and k be temporal variables ordered --- according to --- --- i < j < k --- --- and let there be an edge from (i,u) to (k,w) for some indices u and v --- --- Then, we have a contradiction if both the premise (k,w) that requires a --- fact 'f(t,...)' and there is a premise (j,v) requiring a fact 'f(t,...)'. --- --- These two premises would have to be merged, but cannot due to the ordering --- constraint 'j < k'. -nonInjectiveFactInstances :: ProofContext -> System -> [(NodeId, NodeId, NodeId)] -nonInjectiveFactInstances ctxt se = do - Edge c@(i, _) (k, _) <- S.toList $ L.get sEdges se - let kFaPrem = nodeConcFact c se - kTag = factTag kFaPrem - kTerm = firstTerm kFaPrem - conflictingFact fa = factTag fa == kTag && firstTerm fa == kTerm - - guard (kTag `S.member` L.get pcInjectiveFactInsts ctxt) - j <- S.toList $ D.reachableSet [i] less - - let isCounterExample = (j /= i) && (j /= k) && - maybe False checkRule (M.lookup j $ L.get sNodes se) - - -- FIXME: There should be a weaker version of the rule that just - -- introduces the constraint 'k < j || k == j' here. - checkRule jRu = any conflictingFact (L.get rPrems jRu) && - k `S.member` D.reachableSet [j] less - - guard isCounterExample - return (i, j, k) -- counter-example to unique fact instances - where - less = rawLessRel se - firstTerm = headMay . factTerms - --- | The node-ids that must be instantiated to the trace, but are temporally --- after the last node. -nodesAfterLast :: System -> [(NodeId, NodeId)] -nodesAfterLast sys = case L.get sLastAtom sys of - Nothing -> [] - Just i -> do j <- S.toList $ D.reachableSet [i] $ rawLessRel sys - guard (j /= i && isInTrace sys j) - return (i, j) - - --- | Pretty-print a 'Contradiction'. -prettyContradiction :: Document d => Contradiction -> d -prettyContradiction contra = case contra of - Cyclic -> text "cyclic" - IncompatibleEqs -> text "incompatible equalities" - NonNormalTerms -> text "non-normal terms" - ForbiddenExp -> text "non-normal exponentiation instance" - NonInjectiveFactInstance cex -> text $ "non-injective facts " ++ show cex - FormulasFalse -> text "from formulas" - SuperfluousLearn m v -> - doubleQuotes (prettyLNTerm m) <-> - text ("derived before and after") <-> - doubleQuotes (prettyNodeId v) - NodeAfterLast (i,j) -> - text $ "node " ++ show j ++ " after last node " ++ show i - - --- Instances ------------- - -instance HasFrees Contradiction where - foldFrees f (SuperfluousLearn t v) = foldFrees f t `mappend` foldFrees f v - foldFrees f (NonInjectiveFactInstance x) = foldFrees f x - foldFrees f (NodeAfterLast x) = foldFrees f x - foldFrees _ _ = mempty - - mapFrees f (SuperfluousLearn t v) = SuperfluousLearn <$> mapFrees f t <*> mapFrees f v - mapFrees f (NonInjectiveFactInstance x) = NonInjectiveFactInstance <$> mapFrees f x - mapFrees f (NodeAfterLast x) = NodeAfterLast <$> mapFrees f x - mapFrees _ c = pure c - -$( derive makeBinary ''Contradiction) -$( derive makeNFData ''Contradiction) diff --git a/src/Theory/Constraint/Solver/Goals.hs b/src/Theory/Constraint/Solver/Goals.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver/Goals.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- The constraint reduction rules, which are not enforced as invariants in --- "Theory.Constraint.Solver.Reduction". --- --- A goal represents a possible application of a rule that may result in --- multiple cases or even non-termination (if applied repeatedly). These goals --- are computed as the list of 'openGoals'. See --- "Theory.Constraint.Solver.ProofMethod" for the public interface to solving --- goals and the implementation of heuristics. -module Theory.Constraint.Solver.Goals ( - Usefulness(..) - , AnnotatedGoal - , openGoals - , solveGoal - ) where - -import Prelude hiding (id, (.)) - -import qualified Data.DAG.Simple as D (cyclic) -import qualified Data.Map as M -import qualified Data.Set as S - -import Control.Basics -import Control.Category -import Control.Monad.Disj -import Control.Monad.State (gets) - -import Extension.Data.Label - -import Theory.Constraint.Solver.Contradictions (substCreatesNonNormalTerms) -import Theory.Constraint.Solver.Reduction -import Theory.Constraint.Solver.Types -import Theory.Constraint.System -import Theory.Model - - ------------------------------------------------------------------------------- --- Extracting Goals ------------------------------------------------------------------------------- - -data Usefulness = - Useful - -- ^ A goal that is likely to result in progress. - | LoopBreaker - -- ^ A goal that is delayed to avoid immediate termination. Needs to be - -- handled fairly. - | ProbablySolvable - -- ^ A goal that is very likely to be solvable without introducing further - -- interesting constraints. These goals are delayed until the very end. - deriving (Show, Eq) - --- | Goals annotated with their number and usefulness. -type AnnotatedGoal = (Goal, (Integer, Usefulness)) - - --- Instances ------------- - --- We need a custom 'Ord' instance that guarantees that @Useful < Useless@. -instance Ord Usefulness where - compare a b = - check a b - where - check Useful Useful = EQ - check LoopBreaker LoopBreaker = EQ - check ProbablySolvable ProbablySolvable = EQ - check x y = compare (tag x) (tag y) - - tag (Useful) = 0 :: Int - tag (LoopBreaker) = 1 - tag (ProbablySolvable) = 2 - - --- | The list of goals that must be solved before a solution can be extracted. --- Each goal is annotated with its age and an indicator for its usefulness. -openGoals :: System -> [AnnotatedGoal] -openGoals sys = do - (goal, status) <- M.toList $ get sGoals sys - let solved = get gsSolved status - -- check whether the goal is still open - guard $ case goal of - ActionG _ (kFactView -> Just (UpK, m)) -> - not $ solved - || isMsgVar m || sortOfLNTerm m == LSortPub - -- handled by 'insertAction' - || isPair m || isInverse m || isProduct m - || isNullaryFunction m - ActionG _ _ -> not solved - PremiseG _ _ -> not solved - -- Technically the 'False' disj would be a solvable goal. However, we - -- have a separate proof method for this, i.e., contradictions. - DisjG (Disj []) -> False - DisjG _ -> not solved - - ChainG c _ -> - case kFactView (nodeConcFact c sys) of - Just (DnK, m) | isMsgVar m -> False - | otherwise -> not solved - fa -> error $ "openChainGoals: impossible fact: " ++ show fa - - -- FIXME: Split goals may be duplicated, we always have to check - -- explicitly if they still exist. - SplitG idx -> splitExists (get sEqStore sys) idx - - let - useful = case goal of - _ | get gsLoopBreaker status -> LoopBreaker - ActionG i (kFactView -> Just (UpK, m)) - -- if there are KU-guards then all knowledge goals are useful - | hasKUGuards -> Useful - | isSimpleTerm m || deducible i m -> ProbablySolvable - _ -> Useful - - return (goal, (get gsNr status, useful)) - where - existingDeps = rawLessRel sys - hasKUGuards = - any ((KUFact `elem`) . guardFactTags) $ S.toList $ get sFormulas sys - - -- We use the following heuristic for marking KU-actions as useful (worth - -- solving now) or useless (to be delayed until no more useful goals - -- remain). We ignore all goals that are simple terms 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 looking for as a - -- toplevel term. If such a node exist, then solving the goal will result - -- in at least one case where we didn't make real progress except. - toplevelTerms t@(destPair -> Just (t1, t2)) = - t : toplevelTerms t1 ++ toplevelTerms t2 - toplevelTerms t@(destInverse -> Just t1) = t : toplevelTerms t1 - toplevelTerms t = [t] - - deducible i m = or $ do - (j, ru) <- M.toList $ get sNodes sys - -- We cannot deduce a message from a last node. - guard (not $ isLast sys j) - let derivedMsgs = concatMap toplevelTerms $ - [ t | Fact OutFact [t] <- get rConcs ru] <|> - [ t | Just (DnK, t) <- kFactView <$> get rConcs ru] - -- m is deducible from j without an immediate contradiction - -- if it is a derived message of 'ru' and the dependency does - -- not make the graph cyclic. - return $ m `elem` derivedMsgs && - not (D.cyclic ((j, i) : existingDeps)) - - ------------------------------------------------------------------------------- --- Solving 'Goal's ------------------------------------------------------------------------------- - --- | @solveGoal rules goal@ enumerates all possible cases of how this goal --- could be solved in the context of the given @rules@. For each case, a --- sensible case-name is returned. -solveGoal :: Goal -> Reduction String -solveGoal goal = do - -- mark before solving, as representation might change due to unification - markGoalAsSolved "directly" goal - rules <- askM pcRules - case goal of - ActionG i fa -> solveAction (nonSilentRules rules) (i, fa) - PremiseG p fa -> - solvePremise (get crProtocol rules ++ get crConstruct rules) p fa - ChainG c p -> solveChain (get crDestruct rules) (c, p) - SplitG i -> solveSplit i - DisjG disj -> solveDisjunction disj - --- The follwoing functions are internal to 'solveGoal'. Use them with great --- care. - --- | CR-rule *S_at*: solve an action goal. -solveAction :: [RuleAC] -- ^ All rules labelled with an action - -> (NodeId, LNFact) -- ^ The action we are looking for. - -> Reduction String -- ^ A sensible case name. -solveAction rules (i, fa) = do - mayRu <- M.lookup i <$> getM sNodes - showRuleCaseName <$> case mayRu of - Nothing -> do ru <- labelNodeId i rules - act <- disjunctionOfList $ get rActs ru - void (solveFactEqs SplitNow [Equal fa act]) - return ru - - Just ru -> do unless (fa `elem` get rActs ru) $ do - act <- disjunctionOfList $ get rActs ru - void (solveFactEqs SplitNow [Equal fa act]) - return ru - --- | CR-rules *DG_{2,P}* and *DG_{2,d}*: solve a premise with a direct edge --- from a unifying conclusion or using a destruction chain. --- --- Note that *In*, *Fr*, and *KU* facts are solved directly when adding a --- 'ruleNode'. --- -solvePremise :: [RuleAC] -- ^ All rules with a non-K-fact conclusion. - -> NodePrem -- ^ Premise to solve. - -> LNFact -- ^ Fact required at this premise. - -> Reduction String -- ^ Case name to use. -solvePremise rules p faPrem - | isKDFact faPrem = do - iLearn <- freshLVar "vl" LSortNode - mLearn <- varTerm <$> freshLVar "t" LSortMsg - let concLearn = kdFact mLearn - premLearn = outFact mLearn - -- !! Make sure that you construct the correct rule! - ruLearn = Rule (IntrInfo IRecvRule) [premLearn] [concLearn] [] - cLearn = (iLearn, ConcIdx 0) - pLearn = (iLearn, PremIdx 0) - modM sNodes (M.insert iLearn ruLearn) - insertChain cLearn p - solvePremise rules pLearn premLearn - - | otherwise = do - (ru, c, faConc) <- insertFreshNodeConc rules - insertEdges [(c, faConc, faPrem, p)] - return $ showRuleCaseName ru - --- | CR-rule *DG2_chain*: solve a chain constraint. -solveChain :: [RuleAC] -- ^ All destruction rules. - -> (NodeConc, NodePrem) -- ^ The chain to extend by one step. - -> Reduction String -- ^ Case name to use. -solveChain rules (c, p) = do - faConc <- gets $ nodeConcFact c - (do -- solve it by a direct edge - faPrem <- gets $ nodePremFact p - insertEdges [(c, faConc, faPrem, p)] - let m = case kFactView faConc of - Just (DnK, m') -> m' - _ -> error $ "solveChain: impossible" - caseName (viewTerm -> FApp o _) = showFunSymName o - caseName t = show t - return $ caseName m - `disjunction` - do -- extend it with one step - cRule <- gets $ nodeRule (nodeConcNode c) - (i, ru) <- insertFreshNode rules - -- contradicts normal form condition: - -- no edge from dexp to dexp KD premise - -- (this condition replaces the exp/noexp tags) - contradictoryIf (isDexpRule cRule && isDexpRule ru) - (v, faPrem) <- disjunctionOfList $ enumPrems ru - insertEdges [(c, faConc, faPrem, (i, v))] - markGoalAsSolved "directly" (PremiseG (i, v) faPrem) - insertChain (i, ConcIdx 0) p - return $ showRuleCaseName ru - ) - where - isDexpRule ru = case get rInfo ru of - IntrInfo (DestrRule n) | n == expSymString -> True - _ -> False - --- | Solve an equation split. There is no corresponding CR-rule in the rule --- system on paper because there we eagerly split over all variants of a rule. --- In practice, this is too expensive and we therefore use the equation store --- to delay these splits. -solveSplit :: SplitId -> Reduction String -solveSplit x = do - split <- gets ((`performSplit` x) . get sEqStore) - let errMsg = error "solveSplit: inexistent split-id" - store <- maybe errMsg disjunctionOfList split - -- FIXME: Simplify this interaction with the equation store - hnd <- getMaudeHandle - substCheck <- gets (substCreatesNonNormalTerms hnd) - store' <- simp hnd substCheck store - contradictoryIf (eqsIsFalse store') - sEqStore =: store' - return "split" - --- | CR-rule *S_disj*: solve a disjunction of guarded formulas using a case --- distinction. --- --- In contrast to the paper, we use n-ary disjunctions and also split over all --- of them at once. -solveDisjunction :: Disj LNGuarded -> Reduction String -solveDisjunction disj = do - (i, gfm) <- disjunctionOfList $ zip [(1::Int)..] $ getDisj disj - insertFormula gfm - return $ "case_" ++ show i - diff --git a/src/Theory/Constraint/Solver/ProofMethod.hs b/src/Theory/Constraint/Solver/ProofMethod.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver/ProofMethod.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Proof methods and heuristics: the external small-step interface to the --- constraint solver. -module Theory.Constraint.Solver.ProofMethod ( - -- * Proof methods - CaseName - , ProofMethod(..) - , execProofMethod - - -- ** Heuristics - , GoalRanking(..) - , goalRankingName - , rankProofMethods - - , Heuristic - , roundRobinHeuristic - , useHeuristic - - -- ** Pretty Printing - , prettyProofMethod - -) where - -import Data.Binary -import Data.DeriveTH -import Data.Function (on) -import Data.Label hiding (get) -import qualified Data.Label as L -import Data.List -import qualified Data.Map as M -import Data.Monoid -import Data.Ord (comparing) -import qualified Data.Set as S -import Extension.Prelude (sortOn) - -import Control.Basics -import Control.DeepSeq -import Control.Monad.Bind -import qualified Control.Monad.Trans.PreciseFresh as Precise - -import Theory.Constraint.Solver.CaseDistinctions -import Theory.Constraint.Solver.Contradictions -import Theory.Constraint.Solver.Goals -import Theory.Constraint.Solver.Reduction -import Theory.Constraint.Solver.Simplify -import Theory.Constraint.Solver.Types -import Theory.Constraint.System -import Theory.Model -import Theory.Text.Pretty - - ------------------------------------------------------------------------------- --- Utilities ------------------------------------------------------------------------------- - --- | @uniqueListBy eq changes xs@ zips the @changes@ with all sequences equal --- elements in the list. --- --- > uniqueListBy compare id (const [ (++ show i) | i <- [1..] ]) ["a","b","a"] = --- > ["a1","b","a2"] --- -uniqueListBy :: (a -> a -> Ordering) -> (a -> a) -> (Int -> [a -> a]) -> [a] -> [a] -uniqueListBy ord single distinguish xs0 = - map fst - $ sortBy (comparing snd) - $ concat $ map uniquify $ groupBy (\x y -> ord (fst x) (fst y) == EQ) - $ sortBy (ord `on` fst) - $ zip xs0 [(0::Int)..] - where - uniquify [] = error "impossible" - uniquify [(x,i)] = [(single x, i)] - uniquify xs = zipWith (\f (x,i) -> (f x, i)) dist xs - where - dist = distinguish $ length xs - - ------------------------------------------------------------------------------- --- Proof Methods ------------------------------------------------------------------------------- - --- | Every case in a proof is uniquely named. -type CaseName = String - --- | Sound transformations of sequents. -data ProofMethod = - Sorry (Maybe String) -- ^ Proof was not completed - | Solved -- ^ An attack was fond - | Simplify -- ^ A simplification step. - | SolveGoal Goal -- ^ A goal that was solved. - | Contradiction (Maybe Contradiction) -- ^ A contradiction could be - -- derived, possibly with a reason. - | Induction -- ^ Use inductive strengthening on - -- the single formula constraint in - -- the system. - deriving( Eq, Ord, Show ) - -instance HasFrees ProofMethod where - foldFrees f (SolveGoal g) = foldFrees f g - foldFrees f (Contradiction c) = foldFrees f c - foldFrees _ _ = mempty - - mapFrees f (SolveGoal g) = SolveGoal <$> mapFrees f g - mapFrees f (Contradiction c) = Contradiction <$> mapFrees f c - mapFrees _ method = pure method - - --- Proof method execution -------------------------- - - --- @execMethod rules method se@ checks first if the @method@ is applicable to --- the sequent @se@. Then, it applies the @method@ to the sequent under the --- assumption that the @rules@ describe all rewriting rules in scope. --- --- NOTE that the returned systems have their free substitution fully applied --- and all variable indices reset. -execProofMethod :: ProofContext - -> ProofMethod -> System -> Maybe (M.Map CaseName System) -execProofMethod ctxt method sys = - M.map cleanupSystem <$> - case method of - Sorry _ -> return M.empty - Solved - | null (openGoals sys) -> return M.empty - | otherwise -> Nothing - SolveGoal goal - | goal `M.member` L.get sGoals sys -> execSolveGoal goal - | otherwise -> Nothing - Simplify -> singleCase (/=) simplifySystem - Induction -> execInduction - Contradiction _ - | null (contradictions ctxt sys) -> Nothing - | otherwise -> Just M.empty - where - -- at this point it is safe to remove the free substitution, as all - -- systems have it fully applied (by the virtue of a call to - -- simplifySystem). We also reset the variable indices here. - cleanupSystem = - (`Precise.evalFresh` Precise.nothingUsed) - . (`evalBindT` noBindings) - . someInst - . set sSubst emptySubst - - - -- expect only one or no subcase in the given case distinction - singleCase check m = - case map fst $ getDisj $ execReduction m ctxt sys (avoid sys) of - [] -> return $ M.empty - [sys'] | check sys sys' -> return $ M.singleton "" sys' - | otherwise -> mzero - syss -> - return $ M.fromList (zip (map show [(1::Int)..]) syss) - - -- solve the given goal - -- PRE: Goal must be valid in this system. - execSolveGoal goal = do - return $ makeCaseNames $ map fst $ getDisj $ - runReduction solver ctxt sys (avoid sys) - where - ths = L.get pcCaseDists ctxt - solver = do name <- maybe (solveGoal goal) - (fmap $ concat . intersperse "_") - (solveWithCaseDistinction ctxt ths goal) - simplifySystem - return name - - makeCaseNames = - M.fromListWith (error "case names not unique") - . uniqueListBy (comparing fst) id distinguish - where - distinguish n = - [ (\(x,y) -> (x ++ "_case_" ++ pad (show i), y)) - | i <- [(1::Int)..] ] - where - l = length (show n) - pad cs = replicate (l - length cs) '0' ++ cs - - -- Apply induction: possible if the system contains only - -- a single, last-free, closed formula. - execInduction - | sys == sys0 = - case S.toList $ L.get sFormulas sys of - [gf] -> case ginduct gf of - Right (bc, sc) -> Just $ insCase "empty_trace" bc - $ insCase "non_empty_trace" sc - $ M.empty - _ -> Nothing - _ -> Nothing - - | otherwise = Nothing - where - sys0 = set sFormulas (L.get sFormulas sys) - $ set sLemmas (L.get sLemmas sys) - $ emptySystem (L.get sCaseDistKind sys) - - insCase name gf = M.insert name (set sFormulas (S.singleton gf) sys) - ------------------------------------------------------------------------------- --- Heuristics ------------------------------------------------------------------------------- - --- | The different available functions to rank goals with respect to their --- order of solving in a constraint system. -data GoalRanking = - GoalNrRanking - | UsefulGoalNrRanking - | SmartRanking Bool - deriving( Eq, Ord, Show ) - --- | The name/explanation of a 'GoalRanking'. -goalRankingName :: GoalRanking -> String -goalRankingName ranking = - "Goals sorted according to " ++ case ranking of - GoalNrRanking -> "their order of creation" - UsefulGoalNrRanking -> "their usefulness and order of creation" - SmartRanking useLoopBreakers -> smart useLoopBreakers - where - smart b = "the 'smart' heuristic (loop breakers " ++ - (if b then "allowed" else "delayed") ++ ")." - --- | Use a 'GoalRanking' to sort a list of 'AnnotatedGoal's stemming from the --- given constraint 'System'. -rankGoals :: GoalRanking -> System -> [AnnotatedGoal] -> [AnnotatedGoal] -rankGoals ranking = case ranking of - GoalNrRanking -> \_sys -> goalNrRanking - UsefulGoalNrRanking -> - \_sys -> sortOn (\(_, (nr, useless)) -> (useless, nr)) - SmartRanking useLoopsBreakers -> smartRanking useLoopsBreakers - --- | Use a 'GoalRanking' to generate the ranked, list of possible --- 'ProofMethod's and their corresponding results in this 'ProofContext' and --- for this 'System'. If the resulting list is empty, then the constraint --- system is solved. -rankProofMethods :: GoalRanking -> ProofContext -> System - -> [(ProofMethod, (M.Map CaseName System, String))] -rankProofMethods ranking ctxt sys = do - (m, expl) <- - (contradiction <$> contradictions ctxt sys) - <|> (case L.get pcUseInduction ctxt of - AvoidInduction -> [(Simplify, ""), (Induction, "")] - UseInduction -> [(Induction, ""), (Simplify, "")] - ) - <|> (solveGoalMethod <$> (rankGoals ranking sys $ openGoals sys)) - case execProofMethod ctxt m sys of - Just cases -> return (m, (cases, expl)) - Nothing -> [] - where - contradiction c = (Contradiction (Just c), "") - solveGoalMethod (goal, (nr, usefulness)) = - ( SolveGoal goal - , "nr. " ++ show nr ++ case usefulness of - Useful -> "" - LoopBreaker -> " (loop breaker)" - ProbablySolvable -> " (probably solvable)" - ) - -newtype Heuristic = Heuristic [GoalRanking] - deriving( Eq, Ord, Show ) - --- | Smart constructor for heuristics. Schedules the goal rankings in a --- round-robin fashion dependent on the proof depth. -roundRobinHeuristic :: [GoalRanking] -> Heuristic -roundRobinHeuristic = Heuristic - --- | Use a heuristic to schedule a 'GoalRanking' according to the given --- proof-depth. -useHeuristic :: Heuristic -> Int -> GoalRanking -useHeuristic (Heuristic [] ) = error "useHeuristic: empty list of rankings" -useHeuristic (Heuristic rankings) = - ranking - where - n = length rankings - - ranking depth - | depth < 0 = error $ "useHeuristic: negative proof depth " ++ show depth - | otherwise = rankings !! (depth `mod` n) - - - -{- --- | Schedule the given local-heuristics in a round-robin fashion. -roundRobinHeuristic :: [GoalRanking] -> Heuristic -roundRobinHeuristic [] = error "roundRobin: empty list of rankings" -roundRobinHeuristic rankings = - methods - where - n = length rankings - - methods depth ctxt sys - | depth < 0 = error $ "roundRobin: negative proof depth " ++ show depth - | otherwise = - ( name - , ((Contradiction . Just) <$> contradictions ctxt sys) - <|> (case L.get pcUseInduction ctxt of - AvoidInduction -> [Simplify, Induction] - UseInduction -> [Induction, Simplify] - ) - <|> ((SolveGoal . fst) <$> (ranking sys $ openGoals sys)) - ) - where - (name, ranking) = rankings !! (depth `mod` n) --} - --- | Sort annotated goals according to their number. -goalNrRanking :: [AnnotatedGoal] -> [AnnotatedGoal] -goalNrRanking = sortOn (fst . snd) - --- | A ranking function tuned for the automatic verification of --- classical security protocols that exhibit a well-founded protocol premise --- fact flow. -smartRanking :: Bool -- True if PremiseG loop-breakers should not be delayed - -> System - -> [AnnotatedGoal] -> [AnnotatedGoal] -smartRanking allowPremiseGLoopBreakers sys = - sortOnUsefulness . unmark . sortDecisionTree solveFirst . goalNrRanking - where - sortOnUsefulness = sortOn (snd . snd) - - unmark | allowPremiseGLoopBreakers = map unmarkPremiseG - | otherwise = id - - unmarkPremiseG (goal@(PremiseG _ _), (nr, _)) = (goal, (nr, Useful)) - unmarkPremiseG annGoal = annGoal - - solveFirst = - [ isChainGoal . fst - , isDisjGoal . fst - , isNonLoopBreakerProtoFactGoal - , isStandardActionGoal . fst - , isFreshKnowsGoal . fst - , isSplitGoalSmall . fst - , isDoubleExpGoal . fst - , isNoLargeSplitGoal . fst ] - -- move the rest (mostly more expensive KU-goals) before expensive - -- equation splits - - -- FIXME: This small split goal preferral is quite hacky when using - -- induction. The problem is that we may end up solving message premise - -- goals all the time instead performing a necessary split. We should make - -- sure that a split does not get too old. - smallSplitGoalSize = 3 - - isNonLoopBreakerProtoFactGoal (PremiseG _ fa, (_, Useful)) = not $ isKFact fa - isNonLoopBreakerProtoFactGoal _ = False - - msgPremise (ActionG _ fa) = do (UpK, m) <- kFactView fa; return 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 - - -- Be conservative on splits that don't exist. - isSplitGoalSmall (SplitG sid) = - maybe False (<= smallSplitGoalSize) $ splitSize (L.get sEqStore sys) sid - isSplitGoalSmall _ = False - - isNoLargeSplitGoal goal@(SplitG _) = isSplitGoalSmall goal - isNoLargeSplitGoal _ = True - - -- | @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 - - - ------------------------------------------------------------------------------- --- Pretty printing ------------------------------------------------------------------------------- - --- | Pretty-print a proof method. -prettyProofMethod :: HighlightDocument d => ProofMethod -> d -prettyProofMethod method = case method of - Solved -> keyword_ "SOLVED" <-> lineComment_ "trace found" - Induction -> keyword_ "induction" - Sorry reason -> - fsep [keyword_ "sorry", maybe emptyDoc lineComment_ reason] - SolveGoal goal -> - keyword_ "solve(" <-> prettyGoal goal <-> keyword_ ")" - Simplify -> keyword_ "simplify" - Contradiction reason -> - sep [ keyword_ "contradiction" - , maybe emptyDoc (lineComment . prettyContradiction) reason - ] - - - --- Derived instances --------------------- - -$( derive makeBinary ''ProofMethod) -$( derive makeBinary ''GoalRanking) -$( derive makeBinary ''Heuristic) - -$( derive makeNFData ''ProofMethod) -$( derive makeNFData ''GoalRanking) -$( derive makeNFData ''Heuristic) diff --git a/src/Theory/Constraint/Solver/Reduction.hs b/src/Theory/Constraint/Solver/Reduction.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver/Reduction.hs +++ /dev/null @@ -1,665 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- A monad for writing constraint reduction steps together with basic steps --- for inserting nodes, edges, actions, and equations and applying --- substitutions. -module Theory.Constraint.Solver.Reduction ( - -- * The constraint 'Reduction' monad - Reduction - , execReduction - , runReduction - - -- ** Change management - , ChangeIndicator(..) - , whenChanged - , applyChangeList - , whileChanging - - -- ** Accessing the 'ProofContext' - , getProofContext - , getMaudeHandle - - -- ** Inserting nodes, edges, and atoms - , labelNodeId - , insertFreshNode - , insertFreshNodeConc - - , insertGoal - , insertAtom - , insertEdges - , insertChain - , insertAction - , insertLess - , insertFormula - , reducibleFormula - - -- ** Goal management - , markGoalAsSolved - , removeSolvedSplitGoals - - -- ** Substitution application - , substSystem - , substNodes - , substEdges - , substLastAtom - , substLessAtoms - , substFormulas - , substSolvedFormulas - - -- ** Solving equalities - , SplitStrategy(..) - - , solveNodeIdEqs - , solveTermEqs - , solveFactEqs - , solveRuleEqs - , solveSubstEqs - - -- ** Conjunction with another constraint 'System' - , conjoinSystem - - -- ** Convenience export - , module Logic.Connectives - - ) where - -import Debug.Trace -import Prelude hiding (id, (.)) - -import qualified Data.Foldable as F -import qualified Data.Map as M -import qualified Data.Set as S -import Data.List (mapAccumL) -import Safe - -import Control.Basics -import Control.Category -import Control.Monad.Bind -import Control.Monad.Disj -import Control.Monad.Reader -import Control.Monad.State (StateT, execStateT, gets, runStateT) - -import Text.PrettyPrint.Class - -import Extension.Data.Label -import Extension.Data.Monoid (Monoid(..)) -import Extension.Prelude - -import Logic.Connectives - -import Theory.Constraint.Solver.Contradictions -import Theory.Constraint.Solver.Types -import Theory.Constraint.System -import Theory.Model - - ------------------------------------------------------------------------------- --- The constraint reduction monad ------------------------------------------------------------------------------- - --- | A constraint reduction step. Its state is the current constraint system, --- it can generate fresh names, split over cases, and access the proof --- context. -type Reduction = StateT System (FreshT (DisjT (Reader ProofContext))) - - --- Executing reductions ------------------------ - --- | Run a constraint reduction. Returns a list of constraint systems whose --- combined solutions are equal to the solutions of the given system. This --- property is obviously not enforced, but it must be respected by all --- functions of type 'Reduction'. -runReduction :: Reduction a -> ProofContext -> System -> FreshState - -> Disj ((a, System), FreshState) -runReduction m ctxt se fs = - Disj $ (`runReader` ctxt) $ runDisjT $ (`runFreshT` fs) $ runStateT m se - --- | Run a constraint reduction returning only the updated constraint systems --- and the new freshness states. -execReduction :: Reduction a -> ProofContext -> System -> FreshState - -> Disj (System, FreshState) -execReduction m ctxt se fs = - Disj $ (`runReader` ctxt) . runDisjT . (`runFreshT` fs) $ execStateT m se - - --- Change management --------------------- - --- | Indicate whether the constraint system was changed or not. -data ChangeIndicator = Unchanged | Changed - deriving( Eq, Ord, Show ) - -instance Monoid ChangeIndicator where - mempty = Unchanged - - Changed `mappend` _ = Changed - _ `mappend` Changed = Changed - Unchanged `mappend` Unchanged = Unchanged - --- | Return 'True' iff there was a change. -wasChanged :: ChangeIndicator -> Bool -wasChanged Changed = True -wasChanged Unchanged = False - --- | Only apply a monadic action, if there has been a change. -whenChanged :: Monad m => ChangeIndicator -> m () -> m () -whenChanged = when . wasChanged - --- | Apply a list of changes to the proof state. -applyChangeList :: [Reduction ()] -> Reduction ChangeIndicator -applyChangeList [] = return Unchanged -applyChangeList changes = sequence_ changes >> return Changed - --- | Execute a 'Reduction' as long as it results in changes. Indicate whether --- at least one change was performed. -whileChanging :: Reduction ChangeIndicator -> Reduction ChangeIndicator -whileChanging reduction = - go Unchanged - where - go indicator = do indicator' <- reduction - case indicator' of - Unchanged -> return indicator - Changed -> go indicator' - - --- Accessing the proof context ------------------------------- - --- | Retrieve the 'ProofContext'. -getProofContext :: Reduction ProofContext -getProofContext = ask - --- | Retrieve the 'MaudeHandle' from the 'ProofContext'. -getMaudeHandle :: Reduction MaudeHandle -getMaudeHandle = askM pcMaudeHandle - - --- Inserting (fresh) nodes into the constraint system ------------------------------------------------------ - --- | Insert a fresh rule node labelled with a fresh instance of one of the --- rules and return one of the conclusions. -insertFreshNodeConc :: [RuleAC] -> Reduction (RuleACInst, NodeConc, LNFact) -insertFreshNodeConc rules = do - (i, ru) <- insertFreshNode rules - (v, fa) <- disjunctionOfList $ enumConcs ru - return (ru, (i, v), fa) - --- | Insert a fresh rule node labelled with a fresh instance of one of the rules --- and solve it's 'Fr', 'In', and 'KU' premises immediatly. -insertFreshNode :: [RuleAC] -> Reduction (NodeId, RuleACInst) -insertFreshNode rules = do - i <- freshLVar "vr" LSortNode - (,) i <$> labelNodeId i rules - --- | Label a node-id with a fresh instance of one of the rules and --- solve it's 'Fr', 'In', and 'KU' premises immediatly. --- --- PRE: Node must not yet be labelled with a rule. -labelNodeId :: NodeId -> [RuleAC] -> Reduction RuleACInst -labelNodeId = \i rules -> do - (ru, mrconstrs) <- importRule =<< disjunctionOfList rules - solveRuleConstraints mrconstrs - modM sNodes (M.insert i ru) - exploitPrems i ru - return ru - where - -- | Import a rule with all its variables renamed to fresh variables. - importRule ru = someRuleACInst ru `evalBindT` noBindings - - mkISendRuleAC m = return $ Rule (IntrInfo (ISendRule)) - [kuFact m] [inFact m] [kLogFact m] - - - mkFreshRuleAC m = Rule (ProtoInfo (ProtoRuleACInstInfo FreshRule [])) - [] [freshFact m] [] - - exploitPrems i ru = mapM_ (exploitPrem i ru) (enumPrems ru) - - exploitPrem i ru (v, fa) = case fa of - -- CR-rule *DG2_2* specialized for *In* facts. - Fact InFact [m] -> do - j <- freshLVar "vf" LSortNode - ruKnows <- mkISendRuleAC m - modM sNodes (M.insert j ruKnows) - modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i, v)) - exploitPrems j ruKnows - - -- CR-rule *DG2_2* specialized for *Fr* facts. - Fact FreshFact [m] -> do - j <- freshLVar "vf" LSortNode - modM sNodes (M.insert j (mkFreshRuleAC m)) - unless (isFreshVar m) $ do - -- 'm' must be of sort fresh ==> enforce via unification - n <- varTerm <$> freshLVar "n" LSortFresh - void (solveTermEqs SplitNow [Equal m n]) - modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i,v)) - - -- CR-rule *DG2_{2,u}*: solve a KU-premise by inserting the - -- corresponding KU-actions before this node. - _ | isKUFact fa -> do - j <- freshLVar "vk" LSortNode - insertLess j i - void (insertAction j fa) - - -- Store premise goal for later processing using CR-rule *DG2_2* - | otherwise -> insertGoal (PremiseG (i,v) fa) (v `elem` breakers) - where - breakers = ruleInfo (get praciLoopBreakers) (const []) $ get rInfo ru - --- | Insert a chain constrain. -insertChain :: NodeConc -> NodePrem -> Reduction () -insertChain c p = insertGoal (ChainG c p) False - --- | Insert an edge constraint. CR-rule *DG1_2* is enforced automatically, --- i.e., the fact equalities are enforced. -insertEdges :: [(NodeConc, LNFact, LNFact, NodePrem)] -> Reduction () -insertEdges edges = do - void (solveFactEqs SplitNow [ Equal fa1 fa2 | (_, fa1, fa2, _) <- edges ]) - modM sEdges (\es -> foldr S.insert es [ Edge c p | (c,_,_,p) <- edges]) - --- | Insert an 'Action' atom. Ensures that (almost all) trivial *KU* actions --- are solved immediately using rule *S_{at,u,triv}*. We currently avoid --- adding intermediate products. Indicates whether nodes other than the given --- action have been added to the constraint system. --- --- FIXME: Ensure that intermediate products are also solved before stating --- that no rule is applicable. -insertAction :: NodeId -> LNFact -> Reduction ChangeIndicator -insertAction i fa = do - present <- (goal `M.member`) <$> getM sGoals - if present - then do return Unchanged - else do insertGoal goal False - case kFactView fa of - Just (UpK, viewTerm2 -> FPair m1 m2) -> - requiresKU m1 *> requiresKU m2 *> return Changed - - Just (UpK, viewTerm2 -> FInv m) -> - requiresKU m *> return Changed - - Just (UpK, viewTerm2 -> FMult ms) -> - mapM_ requiresKU ms *> return Changed - - _ -> return Unchanged - where - goal = ActionG i fa - -- Here we rely on the fact that the action is new. Otherwise, we might - -- loop due to generating new KU-nodes that are merged immediately. - requiresKU t = do - j <- freshLVar "vk" LSortNode - let faKU = kuFact t - insertLess j i - void (insertAction j faKU) - --- | Insert a 'Less' atom. @insertLess i j@ means that *i < j* is added. -insertLess :: NodeId -> NodeId -> Reduction () -insertLess i j = modM sLessAtoms (S.insert (i, j)) - --- | Insert a 'Last' atom and ensure their uniqueness. -insertLast :: NodeId -> Reduction ChangeIndicator -insertLast i = do - lst <- getM sLastAtom - case lst of - Nothing -> setM sLastAtom (Just i) >> return Unchanged - Just j -> solveNodeIdEqs [Equal i j] - --- | Insert an atom. Returns 'Changed' if another part of the constraint --- system than the set of actions was changed. -insertAtom :: LNAtom -> Reduction ChangeIndicator -insertAtom ato = case ato of - EqE x y -> solveTermEqs SplitNow [Equal x y] - Action i fa -> insertAction (ltermNodeId' i) fa - Less i j -> do insertLess (ltermNodeId' i) (ltermNodeId' j) - return Unchanged - Last i -> insertLast (ltermNodeId' i) - --- | Insert a 'Guarded' formula. Ensures that existentials, conjunctions, negated --- last atoms, and negated less atoms, are immediately solved using the rules --- *S_exists*, *S_and*, *S_not,last*, and *S_not,less*. Only the inserted --- formula is marked as solved. Other intermediate formulas are not marked. -insertFormula :: LNGuarded -> Reduction () -insertFormula = do - insert True - where - insert mark fm = do - formulas <- getM sFormulas - solvedFormulas <- getM sSolvedFormulas - insert' mark formulas solvedFormulas fm - - insert' mark formulas solvedFormulas fm - | fm `S.member` formulas = return () - | fm `S.member` solvedFormulas = return () - | otherwise = case fm of - GAto ato -> do - markAsSolved - void (insertAtom (bvarToLVar ato)) - - -- CR-rule *S_∧* - GConj fms -> do - markAsSolved - mapM_ (insert False) (getConj fms) - - -- Store for later applications of CR-rule *S_∨* - GDisj disj -> do - modM sFormulas (S.insert fm) - insertGoal (DisjG disj) False - - -- CR-rule *S_∃* - GGuarded Ex ss as gf -> do - -- must always mark as solved, as we otherwise may repeatedly - -- introduce fresh variables. - modM sSolvedFormulas $ S.insert fm - xs <- mapM (uncurry freshLVar) ss - let body = gconj (map GAto as ++ [gf]) - insert False (substBound (zip [0..] (reverse xs)) body) - - -- CR-rule *S_{¬,⋖}* - GGuarded All [] [Less i j] gf | gf == gfalse -> do - markAsSolved - insert False (gdisj [GAto (EqE i j), GAto (Less j i)]) - - -- CR-rule: FIXME add this rule to paper - GGuarded All [] [EqE i@(bltermNodeId -> Just _) - j@(bltermNodeId -> Just _) ] gf - | gf == gfalse -> do - markAsSolved - insert False (gdisj [GAto (Less i j), GAto (Less j i)]) - - -- CR-rule *S_{¬,last}* - GGuarded All [] [Last i] gf | gf == gfalse -> do - markAsSolved - lst <- getM sLastAtom - j <- case lst of - Nothing -> do j <- freshLVar "last" LSortNode - void (insertLast j) - return (varTerm (Free j)) - Just j -> return (varTerm (Free j)) - insert False $ gdisj [ GAto (Less j i), GAto (Less i j) ] - - -- Guarded All quantification: store for saturation - GGuarded All _ _ _ -> modM sFormulas (S.insert fm) - where - markAsSolved = when mark $ modM sSolvedFormulas $ S.insert fm - --- | 'True' iff the formula can be reduced by one of the rules implemented in --- 'insertFormula'. -reducibleFormula :: LNGuarded -> Bool -reducibleFormula fm = case fm of - GAto _ -> True - GConj _ -> True - GGuarded Ex _ _ _ -> True - GGuarded All [] [Less _ _] gf -> gf == gfalse - GGuarded All [] [Last _] gf -> gf == gfalse - _ -> False - - --- Goal management ------------------- - --- | Combine the status of two goals. -combineGoalStatus :: GoalStatus -> GoalStatus -> GoalStatus -combineGoalStatus (GoalStatus solved1 age1 loops1) - (GoalStatus solved2 age2 loops2) = - GoalStatus (solved1 || solved2) (min age1 age2) (loops1 || loops2) - --- | Insert a goal and its status with a new age. Merge status if goal exists. -insertGoalStatus :: Goal -> GoalStatus -> Reduction () -insertGoalStatus goal status = do - age <- getM sNextGoalNr - modM sGoals $ M.insertWith' combineGoalStatus goal (set gsNr age status) - sNextGoalNr =: succ age - --- | Insert a 'Goal' and store its age. -insertGoal :: Goal -> Bool -> Reduction () -insertGoal goal looping = insertGoalStatus goal (GoalStatus False 0 looping) - --- | Mark the given goal as solved. -markGoalAsSolved :: String -> Goal -> Reduction () -markGoalAsSolved how goal = - case goal of - ActionG _ _ -> updateStatus - PremiseG _ fa - | isKDFact fa -> modM sGoals $ M.delete goal - | otherwise -> updateStatus - ChainG _ _ -> modM sGoals $ M.delete goal - SplitG _ -> updateStatus - DisjG disj -> modM sFormulas (S.delete $ GDisj disj) >> - modM sSolvedFormulas (S.insert $ GDisj disj) >> - updateStatus - where - updateStatus = do - mayStatus <- M.lookup goal <$> getM sGoals - case mayStatus of - Just status -> trace (msg status) $ - modM sGoals $ M.insert goal $ set gsSolved True status - Nothing -> trace ("markGoalAsSolved: inexistent goal " ++ show goal) $ return () - - msg status = render $ nest 2 $ fsep $ - [ text ("solved goal nr. "++ show (get gsNr status)) - <-> parens (text how) <> colon - , nest 2 (prettyGoal goal) ] - -removeSolvedSplitGoals :: Reduction () -removeSolvedSplitGoals = do - goals <- getM sGoals - existent <- splitExists <$> getM sEqStore - sequence_ [ modM sGoals $ M.delete goal - | goal@(SplitG i) <- M.keys goals, not (existent i) ] - - --- Substitution ---------------- - --- | Apply the current substitution of the equation store to the remainder of --- the sequent. -substSystem :: Reduction ChangeIndicator -substSystem = do - c1 <- substNodes - substEdges - substLastAtom - substLessAtoms - substFormulas - substSolvedFormulas - substLemmas - c2 <- substGoals - substNextGoalNr - return (c1 <> c2) - --- no invariants to maintain here -substEdges, substLessAtoms, substLastAtom, substFormulas, - substSolvedFormulas, substLemmas, substNextGoalNr :: Reduction () - -substEdges = substPart sEdges -substLessAtoms = substPart sLessAtoms -substLastAtom = substPart sLastAtom -substFormulas = substPart sFormulas -substSolvedFormulas = substPart sSolvedFormulas -substLemmas = substPart sLemmas -substNextGoalNr = return () - - --- | Apply the current substitution of the equation store to a part of the --- sequent. This is an internal function. -substPart :: Apply a => (System :-> a) -> Reduction () -substPart l = do subst <- getM sSubst - modM l (apply subst) - --- | Apply the current substitution of the equation store the nodes of the --- constraint system. Indicates whether additional equalities were added to --- the equations store. -substNodes :: Reduction ChangeIndicator -substNodes = - substNodeIds <* ((modM sNodes . M.map . apply) =<< getM sSubst) - --- | @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. --- Return @True@ iff new equalities have been added to the equation store. -setNodes :: [(NodeId, RuleACInst)] -> Reduction ChangeIndicator -setNodes nodes0 = do - sNodes =: M.fromList nodes - if null ruleEqs then return Unchanged - else solveRuleEqs SplitLater ruleEqs >> return Changed - where - -- merge nodes with equal node id - (ruleEqs, nodes) = first concat $ unzip $ map merge $ groupSortOn fst nodes0 - - merge [] = unreachable "setNodes" - merge (keep:remove) = (map (Equal (snd keep) . snd) remove, keep) - --- | Apply the current substitution of the equation store to the node ids and --- ensure uniqueness of the labels, as required by rule *U_lbl*. Indicates --- whether there where new equalities added to the equations store. -substNodeIds :: Reduction ChangeIndicator -substNodeIds = - whileChanging $ do - subst <- getM sSubst - nodes <- gets (map (first (apply subst)) . M.toList . get sNodes) - setNodes nodes - --- | Substitute all goals. Keep the ones with the lower nr. -substGoals :: Reduction ChangeIndicator -substGoals = do - subst <- getM sSubst - goals <- M.toList <$> getM sGoals - sGoals =: M.empty - changes <- forM goals $ \(goal, status) -> case goal of - -- Look out for KU-actions that might need to be solved again. - ActionG i fa@(kFactView -> Just (UpK, m)) - | (isMsgVar m || isProduct m) && (apply subst m /= m) -> - insertAction i (apply subst fa) - _ -> do modM sGoals $ - M.insertWith' combineGoalStatus (apply subst goal) status - return Unchanged - - return (mconcat changes) - - --- Conjoining two constraint systems ------------------------------------- - --- | @conjoinSystem se@ conjoins the logical information in @se@ to the --- constraint system. It assumes that the free variables in @se@ are shared --- with the free variables in the proof state. -conjoinSystem :: System -> Reduction () -conjoinSystem sys = do - kind <- getM sCaseDistKind - unless (kind == get sCaseDistKind sys) $ - error "conjoinSystem: typing-kind mismatch" - joinSets sSolvedFormulas - joinSets sLemmas - joinSets sEdges - F.mapM_ insertLast $ get sLastAtom sys - F.mapM_ (uncurry insertLess) $ get sLessAtoms sys - -- split-goals are not valid anymore - mapM_ (uncurry insertGoalStatus) $ filter (not . isSplitGoal . fst) $ M.toList $ get sGoals sys - F.mapM_ insertFormula $ get sFormulas sys - -- update nodes - _ <- (setNodes . (M.toList (get sNodes sys) ++) . M.toList) =<< getM sNodes - -- conjoin equation store - eqs <- getM sEqStore - let (eqs',splitIds) = (mapAccumL addDisj eqs (map snd . getConj $ get sConjDisjEqs sys)) - setM sEqStore eqs' - -- add split-goals for all disjunctions of sys - mapM_ (`insertGoal` False) $ SplitG <$> splitIds - void (solveSubstEqs SplitNow $ get sSubst sys) - -- Propagate substitution changes. Ignore change indicator, as it is - -- assumed to be 'Changed' by default. - void substSystem - where - joinSets :: Ord a => (System :-> S.Set a) -> Reduction () - joinSets proj = modM proj (`S.union` get proj sys) - --- Unification via the equation store -------------------------------------- - --- | 'SplitStrategy' denotes if the equation store should be split into --- multiple equation stores. -data SplitStrategy = SplitNow | SplitLater - --- The 'ChangeIndicator' indicates whether at least one non-trivial equality --- was solved. - --- | @noContradictoryEqStore@ suceeds iff the equation store is not --- contradictory. -noContradictoryEqStore :: Reduction () -noContradictoryEqStore = (contradictoryIf . eqsIsFalse) =<< getM sEqStore - --- | Add a list of term equalities to the equation store. And --- split resulting disjunction of equations according --- to given split strategy. --- --- Note that updating the remaining parts of the constraint system with the --- substitution has to be performed using a separate call to 'substSystem'. -solveTermEqs :: SplitStrategy -> [Equal LNTerm] -> Reduction ChangeIndicator -solveTermEqs splitStrat eqs0 = - case filter (not . evalEqual) eqs0 of - [] -> do return Unchanged - eqs1 -> do - hnd <- getMaudeHandle - se <- gets id - (eqs2, maySplitId) <- addEqs hnd eqs1 =<< getM sEqStore - setM sEqStore - =<< simp hnd (substCreatesNonNormalTerms hnd se) - =<< case (maySplitId, splitStrat) of - (Just splitId, SplitNow) -> disjunctionOfList - $ fromJustNote "solveTermEqs" - $ performSplit eqs2 splitId - (Just splitId, SplitLater) -> do - insertGoal (SplitG splitId) False - return eqs2 - _ -> return eqs2 - noContradictoryEqStore - return Changed - --- | Add a list of equalities in substitution form to the equation store -solveSubstEqs :: SplitStrategy -> LNSubst -> Reduction ChangeIndicator -solveSubstEqs split subst = - solveTermEqs split [Equal (varTerm v) t | (v, t) <- substToList subst] - --- | Add a list of node equalities to the equation store. -solveNodeIdEqs :: [Equal NodeId] -> Reduction ChangeIndicator -solveNodeIdEqs = solveTermEqs SplitNow . map (fmap varTerm) - --- | Add a list of fact equalities to the equation store, if possible. -solveFactEqs :: SplitStrategy -> [Equal LNFact] -> Reduction ChangeIndicator -solveFactEqs split eqs = do - contradictoryIf (not $ all evalEqual $ map (fmap factTag) eqs) - solveListEqs (solveTermEqs split) $ map (fmap factTerms) eqs - --- | Add a list of rule equalities to the equation store, if possible. -solveRuleEqs :: SplitStrategy -> [Equal RuleACInst] -> Reduction ChangeIndicator -solveRuleEqs split eqs = do - contradictoryIf (not $ all evalEqual $ map (fmap (get rInfo)) eqs) - solveListEqs (solveFactEqs split) $ - map (fmap (get rConcs)) eqs ++ map (fmap (get rPrems)) eqs - ++ map (fmap (get rActs)) eqs - --- | Solve a number of equalities between lists interpreted as free terms --- using the given solver for solving the entailed per-element equalities. -solveListEqs :: ([Equal a] -> Reduction b) -> [(Equal [a])] -> Reduction b -solveListEqs solver eqs = do - contradictoryIf (not $ all evalEqual $ map (fmap length) eqs) - solver $ concatMap flatten eqs - where - flatten (Equal l r) = zipWith Equal l r - --- | Solve the constraints associated with a rule. -solveRuleConstraints :: Maybe RuleACConstrs -> Reduction () -solveRuleConstraints (Just eqConstr) = do - hnd <- getMaudeHandle - (eqs, splitId) <- addRuleVariants eqConstr <$> getM sEqStore - insertGoal (SplitG splitId) False - -- do not use expensive substCreatesNonNormalTerms here - setM sEqStore =<< simp hnd (const False) eqs - noContradictoryEqStore -solveRuleConstraints Nothing = return () - diff --git a/src/Theory/Constraint/Solver/Simplify.hs b/src/Theory/Constraint/Solver/Simplify.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver/Simplify.hs +++ /dev/null @@ -1,456 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- This module implements all rules that do not result in case distinctions --- and equation solving. Some additional cases may although result from --- splitting over multiple AC-unifiers. Note that a few of these rules are --- implemented directly in the methods for inserting constraints to the --- constraint system. These methods are provided by --- "Theory.Constraint.Solver.Reduction". --- -module Theory.Constraint.Solver.Simplify ( - - simplifySystem - - ) where - -import Debug.Trace - -import Prelude hiding (id, (.)) - -import qualified Data.DAG.Simple as D -import Data.Data -import Data.Either (partitionEithers) -import qualified Data.Foldable as F -import Data.List -import qualified Data.Map as M -import Data.Monoid (Monoid(..)) -import qualified Data.Set as S - -import Control.Basics -import Control.Category -import Control.Monad.Disj -import Control.Monad.Fresh -import Control.Monad.Reader -import Control.Monad.State (gets) - - -import Extension.Data.Label -import Extension.Prelude - -import Theory.Constraint.Solver.Goals -import Theory.Constraint.Solver.Reduction -import Theory.Constraint.Solver.Types -import Theory.Constraint.System -import Theory.Model -import Theory.Text.Pretty - - --- | Apply CR-rules that don't result in case splitting until the constraint --- system does not change anymore. -simplifySystem :: Reduction () -simplifySystem = do - -- Start simplification, indicating that some change happened - go (0 :: Int) [Changed] - -- Add all ordering constraint implied by CR-rule *N6*. - exploitUniqueMsgOrder - -- Remove equation split goals that do not exist anymore - removeSolvedSplitGoals - where - go n changes0 - -- We stop as soon as all simplification steps have been run without - -- reporting any change to the constraint systemm. - | Unchanged == mconcat changes0 = return () - | otherwise = do - -- Store original system for reporting - se0 <- gets id - -- Perform one initial substitution. We do not have to consider its - -- changes as 'substSystem' is idempotent. - void substSystem - -- Perform one simplification pass. - (c1,c2,c3) <- enforceNodeUniqueness - c4 <- enforceEdgeUniqueness - c5 <- solveUniqueActions - c6 <- reduceFormulas - c7 <- evalFormulaAtoms - c8 <- insertImpliedFormulas - - -- Report on looping behaviour if necessary - let changes = filter ((Changed ==) . snd) $ - [ ("unique fresh instances (DG4)", c1) - , ("unique K↓-facts (N5↓)", c2) - , ("unique K↑-facts (N5↑)", c3) - , ("unique (linear) edges (DG2 and DG3)", c4) - , ("solve unambiguous actions (S_@)", c5) - , ("decompose trace formula", c6) - , ("propagate atom valuation to formula", c7) - , ("saturate under ∀-clauses (S_∀)", c8) - ] - traceIfLooping - | n <= 10 = id - | otherwise = trace $ render $ vsep - [ text "Simplifier iteration" <-> int n <> colon - , fsep $ text "The reduction-rules for" : - (punctuate comma $ map (text . fst) changes) ++ - [text "were applied to the following constraint system."] - , nest 2 (prettySystem se0) - ] - - traceIfLooping $ go (n + 1) (map snd changes) - - --- | CR-rule *N6*: add ordering constraints between all KU-actions and --- KD-conclusions. -exploitUniqueMsgOrder :: Reduction () -exploitUniqueMsgOrder = do - kdConcs <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKDConcs) - kuActions <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKUActions) - -- We can add all elements where we have an intersection - F.mapM_ (uncurry insertLess) $ M.intersectionWith (,) kdConcs kuActions - --- | CR-rules *DG4*, *N5_u*, and *N5_d*: enforcing uniqueness of *Fresh* rule --- instances, *KU*-actions, and *KD*-conclusions. --- --- Returns 'Changed' if a change was done. -enforceNodeUniqueness :: Reduction (ChangeIndicator, ChangeIndicator, ChangeIndicator) -enforceNodeUniqueness = - (,,) - <$> (merge (const $ return Unchanged) freshRuleInsts) - <*> (merge (solveRuleEqs SplitNow) kdConcs) - <*> (merge (solveFactEqs SplitNow) kuActions) - where - -- *DG4* - freshRuleInsts se = do - (i, ru) <- M.toList $ get sNodes se - guard (isFreshRule ru) - return (ru, ((), i)) -- no need to merge equal rules - - -- *N5_d* - kdConcs sys = (\(i, ru, m) -> (m, (ru, i))) <$> allKDConcs sys - - -- *N5_u* - kuActions se = (\(i, fa, m) -> (m, (fa, i))) <$> allKUActions se - - merge :: Ord b - => ([Equal a] -> Reduction ChangeIndicator) - -- ^ Equation solver for 'Equal a' - -> (System -> [(b,(a,NodeId))]) - -- ^ Candidate selector - -> Reduction ChangeIndicator -- - merge solver candidates = do - changes <- gets (map mergers . groupSortOn fst . candidates) - mconcat <$> sequence changes - where - mergers [] = unreachable "enforceUniqueness" - mergers ((_,(xKeep, iKeep)):remove) = - mappend <$> solver (map (Equal xKeep . fst . snd) remove) - <*> solveNodeIdEqs (map (Equal iKeep . snd . snd) remove) - - --- | CR-rules *DG2_1* and *DG3*: merge multiple incoming edges to all facts --- and multiple outgoing edges from linear facts. -enforceEdgeUniqueness :: Reduction ChangeIndicator -enforceEdgeUniqueness = do - se <- gets id - let edges = S.toList (get sEdges se) - (<>) <$> mergeNodes eSrc eTgt edges - <*> mergeNodes eTgt eSrc (filter (proveLinearConc se . eSrc) edges) - where - -- | @proveLinearConc se (v,i)@ tries to prove that the @i@-th - -- conclusion of node @v@ is a linear fact. - proveLinearConc se (v, i) = - maybe False (isLinearFact . (get (rConc i))) $ - M.lookup v $ get sNodes se - - -- merge the nodes on the 'mergeEnd' for edges that are equal on the - -- 'compareEnd' - mergeNodes mergeEnd compareEnd edges - | null eqs = return Unchanged - | 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 - where - eqs = concatMap (merge mergeEnd) $ groupSortOn compareEnd edges - - merge _ [] = error "exploitEdgeProps: impossible" - merge proj (keep:remove) = map (Equal (proj keep) . proj) remove - --- | Special version of CR-rule *S_at*, which is only applied to solve actions --- that are guaranteed not to result in case splits. -solveUniqueActions :: Reduction ChangeIndicator -solveUniqueActions = do - rules <- nonSilentRules <$> askM pcRules - actionAtoms <- gets unsolvedActionAtoms - - -- FIXME: We might cache the result of this static computation in the - -- proof-context, e.g., in the 'ClassifiedRules'. - let uniqueActions = [ x | [x] <- group (sort ruleActions) ] - ruleActions = [ (tag, length ts) - | ru <- rules, Fact tag ts <- get rActs ru ] - - isUnique (Fact tag ts) = (tag, length ts) `elem` uniqueActions - - trySolve (i, fa) - | isUnique fa = solveGoal (ActionG i fa) >> return Changed - | otherwise = return Unchanged - - mconcat <$> mapM trySolve actionAtoms - --- | Reduce all formulas as far as possible. See 'insertFormula' for the --- CR-rules exploited in this step. Note that this step is normally only --- required to decompose the formula in the initial constraint system. -reduceFormulas :: Reduction ChangeIndicator -reduceFormulas = do - formulas <- getM sFormulas - applyChangeList $ do - fm <- S.toList formulas - guard (reducibleFormula fm) - return $ do modM sFormulas $ S.delete fm - insertFormula fm - --- | Try to simplify the atoms contained in the formulas. See --- 'partialAtomValuation' for an explanation of what CR-rules are exploited --- here. -evalFormulaAtoms :: Reduction ChangeIndicator -evalFormulaAtoms = do - ctxt <- ask - valuation <- gets (partialAtomValuation ctxt) - formulas <- getM sFormulas - applyChangeList $ do - fm <- S.toList formulas - case simplifyGuarded valuation fm of - Just fm' -> return $ do - case fm of - GDisj disj -> markGoalAsSolved "simplified" (DisjG disj) - _ -> return () - modM sFormulas $ S.delete fm - modM sSolvedFormulas $ S.insert fm - insertFormula fm' - Nothing -> [] - --- | A partial valuation for atoms. The return value of this function is --- interpreted as follows. --- --- @partialAtomValuation ctxt sys ato == Just True@ if for every valuation --- @theta@ satisfying the graph constraints and all atoms in the constraint --- system @sys@, the atom @ato@ is also satisfied by @theta@. --- --- The interpretation for @Just False@ is analogous. @Nothing@ is used to --- represent *unknown*. --- -partialAtomValuation :: ProofContext -> System -> LNAtom -> Maybe Bool -partialAtomValuation ctxt sys = - eval - where - runMaude = (`runReader` get pcMaudeHandle ctxt) - before = alwaysBefore sys - lessRel = rawLessRel sys - nodesAfter = \i -> filter (i /=) $ S.toList $ D.reachableSet [i] lessRel - - -- | 'True' iff there in every solution to the system the two node-ids are - -- instantiated to a different index *in* the trace. - nonUnifiableNodes :: NodeId -> NodeId -> Bool - nonUnifiableNodes i j = maybe False (not . runMaude) $ - (unifiableRuleACInsts) <$> M.lookup i (get sNodes sys) - <*> M.lookup j (get sNodes sys) - - -- | Try to evaluate the truth value of this atom in all models of the - -- constraint system 'sys'. - eval ato = case ato of - Action (ltermNodeId' -> i) fa - | ActionG i fa `M.member` get sGoals sys -> Just True - | otherwise -> - case M.lookup i (get sNodes sys) of - Just ru - | any (fa ==) (get rActs ru) -> Just True - | all (not . runMaude . unifiableLNFacts fa) (get rActs ru) -> Just False - _ -> Nothing - - Less (ltermNodeId' -> i) (ltermNodeId' -> j) - | i == j || j `before` i -> Just False - | i `before` j -> Just True - | isLast sys i && isInTrace sys j -> Just False - | isLast sys j && isInTrace sys i && - nonUnifiableNodes i j -> Just True - | otherwise -> Nothing - - EqE x y - | x == y -> Just True - | not (runMaude (unifiableLNTerms x y)) -> Just False - | otherwise -> - case (,) <$> ltermNodeId x <*> ltermNodeId y of - Just (i, j) - | i `before` j || j `before` i -> Just False - | nonUnifiableNodes i j -> Just False - _ -> Nothing - - Last (ltermNodeId' -> i) - | isLast sys i -> Just True - | any (isInTrace sys) (nodesAfter i) -> Just False - | otherwise -> - case get sLastAtom sys of - Just j | nonUnifiableNodes i j -> Just False - _ -> Nothing - - - --- | CR-rule *S_∀*: insert all newly implied formulas. -insertImpliedFormulas :: Reduction ChangeIndicator -insertImpliedFormulas = do - sys <- gets id - hnd <- getMaudeHandle - applyChangeList $ do - clause <- (S.toList $ get sFormulas sys) ++ - (S.toList $ get sLemmas sys) - implied <- impliedFormulas hnd sys clause - if ( implied `S.notMember` get sFormulas sys && - implied `S.notMember` get sSolvedFormulas sys ) - then return (insertFormula implied) - else [] - --- | @impliedFormulas se imp@ returns the list of guarded formulas that are --- implied by @se@. -impliedFormulas :: MaudeHandle -> System -> LNGuarded -> [LNGuarded] -impliedFormulas hnd sys gf0 = - case openGuarded gf `evalFresh` avoid gf of - Just (All, _vs, antecedent, succedent) -> do - let (actions, otherAtoms) = partitionEithers $ map prepare antecedent - succedent' = gall [] otherAtoms succedent - subst <- candidateSubsts emptySubst actions - return $ unskolemizeLNGuarded $ applySkGuarded subst succedent' - _ -> [] - where - gf = skolemizeGuarded gf0 - - prepare (Action i fa) = Left (i, fa) - prepare ato = Right (fmap (fmapTerm (fmap Free)) ato) - - sysActions = do (i, fa) <- allActions sys - return (skolemizeTerm (varTerm i), skolemizeFact fa) - - candidateSubsts subst [] = do - return subst - candidateSubsts subst (a:as) = do - sysAct <- sysActions - subst' <- (`runReader` hnd) $ matchAction sysAct (applySkAction subst a) - candidateSubsts (compose subst' subst) as - - ------------------------------------------------------------------------------- --- Terms, facts, and formulas with skolem constants ------------------------------------------------------------------------------- - --- | A constant type that supports names and skolem constants. We use the --- skolem constants to represent fixed free variables from the constraint --- system during matching the atoms of a guarded clause to the atoms of the --- constraint system. -data SkConst = SkName Name - | SkConst LVar - deriving( Eq, Ord, Show, Data, Typeable ) - -type SkTerm = VTerm SkConst LVar -type SkFact = Fact SkTerm -type SkSubst = Subst SkConst LVar -type SkGuarded = LGuarded SkConst - --- | A term with skolem constants and bound variables -type BSkTerm = VTerm SkConst BLVar - --- | An term with skolem constants and bound variables -type BSkAtom = Atom BSkTerm - -instance IsConst SkConst - - --- Skolemization of terms without bound variables. --------------------------------------------------- - -skolemizeTerm :: LNTerm -> SkTerm -skolemizeTerm = fmapTerm conv - where - conv :: Lit Name LVar -> Lit SkConst LVar - conv (Var v) = Con (SkConst v) - conv (Con n) = Con (SkName n) - -skolemizeFact :: LNFact -> Fact SkTerm -skolemizeFact = fmap skolemizeTerm - -skolemizeAtom :: BLAtom -> BSkAtom -skolemizeAtom = fmap skolemizeBTerm - -skolemizeGuarded :: LNGuarded -> SkGuarded -skolemizeGuarded = mapGuardedAtoms (const skolemizeAtom) - -applySkTerm :: SkSubst -> SkTerm -> SkTerm -applySkTerm subst t = applyVTerm subst t - -applySkFact :: SkSubst -> SkFact -> SkFact -applySkFact subst = fmap (applySkTerm subst) - -applySkAction :: SkSubst -> (SkTerm,SkFact) -> (SkTerm,SkFact) -applySkAction subst (t,f) = (applySkTerm subst t, applySkFact subst f) - - --- Skolemization of terms with bound variables. ------------------------------------------------ - -skolemizeBTerm :: VTerm Name BLVar -> BSkTerm -skolemizeBTerm = fmapTerm conv - where - conv :: Lit Name BLVar -> Lit SkConst BLVar - conv (Var (Free x)) = Con (SkConst x) - conv (Var (Bound b)) = Var (Bound b) - conv (Con n) = Con (SkName n) - -unskolemizeBTerm :: BSkTerm -> VTerm Name BLVar -unskolemizeBTerm t = fmapTerm conv t - where - conv :: Lit SkConst BLVar -> Lit Name BLVar - conv (Con (SkConst x)) = Var (Free x) - conv (Var (Bound b)) = Var (Bound b) - conv (Var (Free v)) = error $ "unskolemizeBTerm: free variable " ++ - show v++" found in "++show t - conv (Con (SkName n)) = Con n - -unskolemizeBLAtom :: BSkAtom -> BLAtom -unskolemizeBLAtom = fmap unskolemizeBTerm - -unskolemizeLNGuarded :: SkGuarded -> LNGuarded -unskolemizeLNGuarded = mapGuardedAtoms (const unskolemizeBLAtom) - -applyBSkTerm :: SkSubst -> VTerm SkConst BLVar -> VTerm SkConst BLVar -applyBSkTerm subst = - go - where - go t = case viewTerm t of - Lit l -> applyBLLit l - FApp o as -> fApp o (map go as) - - applyBLLit :: Lit SkConst BLVar -> VTerm SkConst BLVar - applyBLLit l@(Var (Free v)) = - 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) - -applySkGuarded :: SkSubst -> LGuarded SkConst -> LGuarded SkConst -applySkGuarded subst = mapGuardedAtoms (const $ applyBSkAtom subst) - --- Matching ------------ - -matchAction :: (SkTerm, SkFact) -> (SkTerm, SkFact) -> WithMaude [SkSubst] -matchAction (i1, fa1) (i2, fa2) = - solveMatchLTerm sortOfSkol (i1 `matchWith` i2 <> fa1 `matchFact` fa2) - where - sortOfSkol (SkName n) = sortOfName n - sortOfSkol (SkConst v) = lvarSort v diff --git a/src/Theory/Constraint/Solver/Types.hs b/src/Theory/Constraint/Solver/Types.hs deleted file mode 100644 --- a/src/Theory/Constraint/Solver/Types.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Common types for our constraint solver. They must be declared jointly --- because there is a recursive dependency between goals, proof contexts, and --- case distinctions. -module Theory.Constraint.Solver.Types ( - - -- * Proof context - ProofContext(..) - , InductionHint(..) - - , pcSignature - , pcRules - , pcInjectiveFactInsts - , pcCaseDists - , pcCaseDistKind - , pcUseInduction - , pcTraceQuantifier - , pcMaudeHandle - - -- ** Classified rules - , ClassifiedRules(..) - , emptyClassifiedRules - , crConstruct - , crDestruct - , crProtocol - , joinAllRules - , nonSilentRules - - -- * Precomputed case distinctions. - , CaseDistinction(..) - - , cdGoal - , cdCases - - ) where - -import Prelude hiding (id, (.)) - -import Data.Binary -import Data.DeriveTH -import Data.Label hiding (get) -import qualified Data.Label as L -import Data.Monoid (Monoid(..)) -import qualified Data.Set as S - -import Control.Basics -import Control.Category -import Control.DeepSeq - -import Logic.Connectives -import Theory.Constraint.System -import Theory.Model - - ----------------------------------------------------------------------- --- ClassifiedRules ----------------------------------------------------------------------- - -data ClassifiedRules = ClassifiedRules - { _crProtocol :: [RuleAC] -- all protocol rules - , _crDestruct :: [RuleAC] -- destruction rules - , _crConstruct :: [RuleAC] -- construction rules - } - deriving( Eq, Ord, Show ) - -$(mkLabels [''ClassifiedRules]) - --- | The empty proof rule set. -emptyClassifiedRules :: ClassifiedRules -emptyClassifiedRules = ClassifiedRules [] [] [] - --- | @joinAllRules rules@ computes the union of all rules classified in --- @rules@. -joinAllRules :: ClassifiedRules -> [RuleAC] -joinAllRules (ClassifiedRules a b c) = a ++ b ++ c - --- | Extract all non-silent rules. -nonSilentRules :: ClassifiedRules -> [RuleAC] -nonSilentRules = filter (not . null . L.get rActs) . joinAllRules - - ------------------------------------------------------------------------------- --- Proof Context ------------------------------------------------------------------------------- - --- | A big-step case distinction. -data CaseDistinction = CaseDistinction - { _cdGoal :: Goal -- 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], System) - } - 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 - , _pcInjectiveFactInsts :: S.Set FactTag - , _pcCaseDistKind :: CaseDistKind - , _pcCaseDists :: [CaseDistinction] - , _pcUseInduction :: InductionHint - , _pcTraceQuantifier :: SystemTraceQuantifier - } - deriving( Eq, Ord, Show ) - -$(mkLabels [''ProofContext, ''CaseDistinction]) - - --- | The 'MaudeHandle' of a proof-context. -pcMaudeHandle :: ProofContext :-> MaudeHandle -pcMaudeHandle = sigmMaudeHandle . pcSignature - --- Instances ------------- - -instance HasFrees CaseDistinction where - foldFrees f th = - foldFrees f (L.get cdGoal th) `mappend` - foldFrees f (L.get cdCases th) - - mapFrees f th = CaseDistinction <$> mapFrees f (L.get cdGoal th) - <*> mapFrees f (L.get cdCases th) - - --- NFData ---------- - -$( derive makeBinary ''CaseDistinction) -$( derive makeBinary ''ClassifiedRules) -$( derive makeBinary ''InductionHint) - -$( derive makeNFData ''CaseDistinction) -$( derive makeNFData ''ClassifiedRules) -$( derive makeNFData ''InductionHint) diff --git a/src/Theory/Constraint/System.hs b/src/Theory/Constraint/System.hs deleted file mode 100644 --- a/src/Theory/Constraint/System.hs +++ /dev/null @@ -1,482 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- This is the public interface for constructing and deconstructing constraint --- systems. The interface for performing constraint solving provided by --- "Theory.Constraint.Solver". -module Theory.Constraint.System ( - -- * Constraints - module Theory.Constraint.System.Constraints - - -- * Constraint systems - , System - - -- ** Construction - , emptySystem - - , SystemTraceQuantifier(..) - , formulaToSystem - - -- ** Node constraints - , sNodes - , allKDConcs - - , nodeRule - , nodeConcNode - , nodePremNode - , nodePremFact - , nodeConcFact - , resolveNodePremFact - , resolveNodeConcFact - - -- ** Actions - , allActions - , allKUActions - , unsolvedActionAtoms - -- FIXME: The two functions below should also be prefixed with 'unsolved' - , kuActionAtoms - , standardActionAtoms - - -- ** Edge and chain constraints - , sEdges - , unsolvedChains - - -- ** Temporal ordering - , sLessAtoms - - , rawLessRel - , rawEdgeRel - - , alwaysBefore - , isInTrace - - -- ** The last node - , sLastAtom - , isLast - - -- ** Equations - , module Theory.Tools.EquationStore - , sEqStore - , sSubst - , sConjDisjEqs - - -- ** Formulas - , sFormulas - , sSolvedFormulas - - -- ** Lemmas - , sLemmas - , insertLemmas - - -- ** Keeping track of typing assumptions - , CaseDistKind(..) - , sCaseDistKind - - -- ** Goals - , GoalStatus(..) - , gsSolved - , gsLoopBreaker - , gsNr - - , sGoals - , sNextGoalNr - - -- * Pretty-printing - , prettySystem - , prettyNonGraphSystem - - ) where - -import Prelude hiding (id, (.)) - -import Data.Binary -import qualified Data.DAG.Simple as D -import Data.DeriveTH -import Data.List (foldl', partition) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(..)) -import qualified Data.Set as S - -import Control.Basics -import Control.Category -import Control.DeepSeq - -import Data.Label ((:->), mkLabels) -import qualified Extension.Data.Label as L - -import Logic.Connectives -import Theory.Constraint.System.Constraints -import Theory.Model -import Theory.Text.Pretty -import Theory.Tools.EquationStore - - - ------------------------------------------------------------------------------- --- Types ------------------------------------------------------------------------------- - --- | 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 SystemTraceQuantifier = ExistsSomeTrace | ExistsNoTrace - deriving( Eq, Ord, Show ) - --- | Case dinstinction kind that are allowed. The order of the kinds --- corresponds to the subkinding relation: untyped < typed. -data CaseDistKind = UntypedCaseDist | TypedCaseDist - deriving( Eq ) - -instance Show CaseDistKind where - show UntypedCaseDist = "untyped" - show TypedCaseDist = "typed" - -instance Ord CaseDistKind where - compare UntypedCaseDist UntypedCaseDist = EQ - compare UntypedCaseDist TypedCaseDist = LT - compare TypedCaseDist UntypedCaseDist = GT - compare TypedCaseDist TypedCaseDist = EQ - --- | The status of a 'Goal'. Use its 'Semigroup' instance to combine the --- status info of goals that collapse. -data GoalStatus = GoalStatus - { _gsSolved :: Bool - -- True if the goal has been solved already. - , _gsNr :: Integer - -- The number of the goal: we use it to track the creation order of - -- goals. - , _gsLoopBreaker :: Bool - -- True if this goal should be solved with care because it may lead to - -- non-termination. - } - deriving( Eq, Ord, Show ) - --- | A constraint system. -data System = System - { _sNodes :: M.Map NodeId RuleACInst - , _sEdges :: S.Set Edge - , _sLessAtoms :: S.Set (NodeId, NodeId) - , _sLastAtom :: Maybe NodeId - , _sEqStore :: EqStore - , _sFormulas :: S.Set LNGuarded - , _sSolvedFormulas :: S.Set LNGuarded - , _sLemmas :: S.Set LNGuarded - , _sGoals :: M.Map Goal GoalStatus - , _sNextGoalNr :: Integer - , _sCaseDistKind :: CaseDistKind - } - -- NOTE: Don't forget the update 'substSystem' in - -- "Constraint.Solver.Reduction" when adding further fields to the - -- constraint system. - deriving( Eq, Ord ) - -$(mkLabels [''System, ''GoalStatus]) - - --- Further accessors --------------------- - --- | Label to access the free substitution of the equation store. -sSubst :: System :-> LNSubst -sSubst = eqsSubst . sEqStore - --- | Label to access the conjunction of disjunctions of fresh substutitution in --- the equation store. -sConjDisjEqs :: System :-> Conj (SplitId, S.Set (LNSubstVFresh)) -sConjDisjEqs = eqsConj . sEqStore - - - ------------------------------------------------------------------------------- --- Constraint system construction ------------------------------------------------------------------------------- - --- | The empty constraint system, which is logically equivalent to true. -emptySystem :: CaseDistKind -> System -emptySystem = System - M.empty S.empty S.empty Nothing emptyEqStore - S.empty S.empty S.empty - M.empty 0 - --- | Returns the constraint system that has to be proven to show that given --- formula holds in the context of the given theory. -formulaToSystem :: [LNGuarded] -- ^ Axioms to add - -> CaseDistKind -- ^ Case distinction kind - -> SystemTraceQuantifier -- ^ Trace quantifier - -> LNFormula - -> System -formulaToSystem axioms kind traceQuantifier fm = - insertLemmas safetyAxioms - $ L.set sFormulas (S.singleton gf2) - $ (emptySystem kind) - where - (safetyAxioms, otherAxioms) = partition isSafetyFormula axioms - gf0 = formulaToGuarded_ fm - gf1 = case traceQuantifier of - ExistsSomeTrace -> gf0 - ExistsNoTrace -> gnot gf0 - -- Non-safety axioms must be added to the formula, as they render the set - -- of traces non-prefix-closed, which makes the use of induction unsound. - gf2 = gconj $ gf1 : otherAxioms - --- | Add a lemma / additional assumption to a constraint system. -insertLemma :: LNGuarded -> System -> System -insertLemma = - go - where - go (GConj conj) = foldr (.) id $ map go $ getConj conj - go fm = L.modify sLemmas (S.insert fm) - --- | Add lemmas / additional assumptions to a constraint system. -insertLemmas :: [LNGuarded] -> System -> System -insertLemmas fms sys = foldl' (flip insertLemma) sys fms - ------------------------------------------------------------------------------- --- Queries ------------------------------------------------------------------------------- - - --- Nodes ------------- - --- | A list of all KD-conclusions in the 'System'. -allKDConcs :: System -> [(NodeId, RuleACInst, LNTerm)] -allKDConcs sys = do - (i, ru) <- M.toList $ L.get sNodes sys - (_, kFactView -> Just (DnK, m)) <- enumConcs ru - return (i, ru, m) - --- | @nodeRule v@ accesses the rule label of node @v@ under the assumption that --- it is present in the sequent. -nodeRule :: NodeId -> System -> RuleACInst -nodeRule v se = - fromMaybe errMsg $ M.lookup v $ L.get sNodes se - where - errMsg = error $ - "nodeRule: node '" ++ show v ++ "' does not exist in sequent\n" ++ - render (nest 2 $ prettySystem se) - - --- | @nodePremFact prem se@ computes the fact associated to premise @prem@ in --- sequent @se@ under the assumption that premise @prem@ is a a premise in --- @se@. -nodePremFact :: NodePrem -> System -> LNFact -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 = fst - --- | All facts associated to this node premise. -resolveNodePremFact :: NodePrem -> System -> Maybe LNFact -resolveNodePremFact (v, i) se = lookupPrem i =<< M.lookup v (L.get sNodes se) - --- | The fact associated with this node conclusion, if there is one. -resolveNodeConcFact :: NodeConc -> System -> Maybe LNFact -resolveNodeConcFact (v, i) se = lookupConc i =<< M.lookup v (L.get sNodes se) - --- | @nodeConcFact (NodeConc (v, i))@ accesses the @i@-th conclusion of the --- rule associated with node @v@ under the assumption that @v@ is labeled with --- a rule that has an @i@-th conclusion. -nodeConcFact :: NodeConc -> System -> LNFact -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 - - --- Actions ----------- - --- | All actions that hold in a sequent. -unsolvedActionAtoms :: System -> [(NodeId, LNFact)] -unsolvedActionAtoms sys = - do (ActionG i fa, status) <- M.toList (L.get sGoals sys) - guard (not $ L.get gsSolved status) - return (i, fa) - --- | All actions that hold in a sequent. -allActions :: System -> [(NodeId, LNFact)] -allActions sys = - unsolvedActionAtoms sys - <|> do (i, ru) <- M.toList $ L.get sNodes sys - (,) i <$> L.get rActs ru - --- | All actions that hold in a sequent. -allKUActions :: System -> [(NodeId, LNFact, LNTerm)] -allKUActions sys = do - (i, fa@(kFactView -> Just (UpK, m))) <- allActions sys - return (i, fa, m) - --- | The standard actions, i.e., non-KU-actions. -standardActionAtoms :: System -> [(NodeId, LNFact)] -standardActionAtoms = filter (not . isKUFact . snd) . unsolvedActionAtoms - --- | All KU-actions. -kuActionAtoms :: System -> [(NodeId, LNFact, LNTerm)] -kuActionAtoms sys = do - (i, fa@(kFactView -> Just (UpK, m))) <- unsolvedActionAtoms sys - return (i, fa, m) - --- Destruction chains ---------------------- - --- | All unsolved destruction chains in the constraint system. -unsolvedChains :: System -> [(NodeConc, NodePrem)] -unsolvedChains sys = do - (ChainG from to, status) <- M.toList $ L.get sGoals sys - guard (not $ L.get gsSolved status) - return (from, to) - - --- The temporal order ---------------------- - --- | @(from,to)@ is in @rawEdgeRel se@ iff we can prove that there is an --- edge-path from @from@ to @to@ in @se@ without appealing to transitivity. -rawEdgeRel :: System -> [(NodeId, NodeId)] -rawEdgeRel sys = map (nodeConcNode *** nodePremNode) $ - [(from, to) | Edge from to <- S.toList $ L.get sEdges sys] - ++ unsolvedChains sys - --- | @(from,to)@ is in @rawLessRel 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. -rawLessRel :: System -> [(NodeId,NodeId)] -rawLessRel se = S.toList (L.get sLessAtoms se) ++ rawEdgeRel se - --- | Returns a predicate that is 'True' iff the first argument happens before --- the second argument in all models of the sequent. -alwaysBefore :: System -> (NodeId -> NodeId -> Bool) -alwaysBefore sys = - check -- lessRel is cached for partial applications - where - lessRel = rawLessRel sys - check i j = - -- speed-up check by first checking less-atoms - ((i, j) `S.member` L.get sLessAtoms sys) - || (j `S.member` D.reachableSet [i] lessRel) - --- | 'True' iff the given node id is guaranteed to be instantiated to an --- index in the trace. -isInTrace :: System -> NodeId -> Bool -isInTrace sys i = - i `M.member` L.get sNodes sys - || isLast sys i - || any ((i ==) . fst) (unsolvedActionAtoms sys) - --- | 'True' iff the given node id is guaranteed to be instantiated to the last --- index of the trace. -isLast :: System -> NodeId -> Bool -isLast sys i = Just i == L.get sLastAtom sys - - - ------------------------------------------------------------------------------- --- Pretty printing -- ------------------------------------------------------------------------------- - --- | Pretty print a sequent -prettySystem :: HighlightDocument d => System -> d -prettySystem se = vcat $ - map combine - [ ("nodes", vcat $ map prettyNode $ M.toList $ L.get sNodes se) - , ("actions", fsepList ppActionAtom $ unsolvedActionAtoms se) - , ("edges", fsepList prettyEdge $ S.toList $ L.get sEdges se) - , ("less", fsepList prettyLess $ S.toList $ L.get sLessAtoms se) - , ("unsolved goals", prettyGoals False se) - ] - ++ [prettyNonGraphSystem se] - where - combine (header, d) = fsep [keyword_ header <> colon, nest 2 d] - ppActionAtom (i, fa) = prettyNAtom (Action (varTerm i) fa) - --- | Pretty print the non-graph part of the sequent; i.e. equation store and --- clauses. -prettyNonGraphSystem :: HighlightDocument d => System -> d -prettyNonGraphSystem se = vsep $ map combine - [ ("last", maybe (text "none") prettyNodeId $ L.get sLastAtom se) - , ("formulas", vsep $ map prettyGuarded $ S.toList $ L.get sFormulas se) - , ("equations", prettyEqStore $ L.get sEqStore se) - , ("lemmas", vsep $ map prettyGuarded $ S.toList $ L.get sLemmas se) - , ("allowed cases", text $ show $ L.get sCaseDistKind se) - , ("solved formulas", vsep $ map prettyGuarded $ S.toList $ L.get sSolvedFormulas se) - , ("solved goals", prettyGoals True se) - ] - where - combine (header, d) = fsep [keyword_ header <> colon, nest 2 d] - --- | Pretty print solved or unsolved goals. -prettyGoals :: HighlightDocument d => Bool -> System -> d -prettyGoals solved sys = vsep $ do - (goal, status) <- M.toList $ L.get sGoals sys - guard (solved == L.get gsSolved status) - let nr = L.get gsNr status - loopBreaker | L.get gsLoopBreaker status = " (loop breaker)" - | otherwise = "" - return $ prettyGoal goal <-> lineComment_ ("nr: " ++ show nr ++ loopBreaker) - - --- Additional instances ------------------------ - -deriving instance Show System - -instance Apply CaseDistKind where - apply = const id - -instance HasFrees CaseDistKind where - foldFrees = const mempty - mapFrees = const pure - -instance HasFrees GoalStatus where - foldFrees = const mempty - mapFrees = const pure - -instance HasFrees System where - foldFrees fun (System a b c d e f g h i j k) = - foldFrees fun a `mappend` - foldFrees fun b `mappend` - foldFrees fun c `mappend` - foldFrees fun d `mappend` - foldFrees fun e `mappend` - foldFrees fun f `mappend` - foldFrees fun g `mappend` - foldFrees fun h `mappend` - foldFrees fun i `mappend` - foldFrees fun j `mappend` - foldFrees fun k - - mapFrees fun (System a b c d e f g h i j k) = - System <$> mapFrees fun a - <*> mapFrees fun b - <*> mapFrees fun c - <*> mapFrees fun d - <*> mapFrees fun e - <*> mapFrees fun f - <*> mapFrees fun g - <*> mapFrees fun h - <*> mapFrees fun i - <*> mapFrees fun j - <*> mapFrees fun k - - -$( derive makeBinary ''CaseDistKind) -$( derive makeBinary ''GoalStatus) -$( derive makeBinary ''System) -$( derive makeBinary ''SystemTraceQuantifier) - -$( derive makeNFData ''CaseDistKind) -$( derive makeNFData ''GoalStatus) -$( derive makeNFData ''System) -$( derive makeNFData ''SystemTraceQuantifier) diff --git a/src/Theory/Constraint/System/Constraints.hs b/src/Theory/Constraint/System/Constraints.hs deleted file mode 100644 --- a/src/Theory/Constraint/System/Constraints.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Types representing constraints. -module Theory.Constraint.System.Constraints ( - -- * Guarded formulas - module Theory.Constraint.System.Guarded - - -- * Graph constraints - , NodePrem - , NodeConc - , Edge(..) - , Less - - -- * Goal constraints - , Goal(..) - , isActionGoal - , isStandardActionGoal - , isPremiseGoal - , isChainGoal - , isSplitGoal - , isDisjGoal - - -- ** Pretty-printing - , prettyNode - , prettyNodePrem - , prettyNodeConc - , prettyEdge - , prettyLess - , prettyGoal - ) where - -import Data.Binary -import Data.DeriveTH -import Data.Generics -import Extension.Data.Monoid (Monoid(..)) - -import Control.Basics -import Control.DeepSeq - -import Text.PrettyPrint.Class -import Text.Unicode - -import Logic.Connectives -import Theory.Constraint.System.Guarded -import Theory.Model -import Theory.Text.Pretty -import Theory.Tools.EquationStore - ------------------------------------------------------------------------------- --- Graph part of a sequent -- ------------------------------------------------------------------------------- - --- | A premise of a node. -type NodePrem = (NodeId, PremIdx) - --- | A conclusion of a node. -type NodeConc = (NodeId, ConcIdx) - --- | A labeled edge in a derivation graph. -data Edge = Edge { - eSrc :: NodeConc - , eTgt :: NodePrem - } - deriving (Show, Ord, Eq, Data, Typeable) - --- | A *⋖* constraint between 'NodeId's. -type Less = (NodeId, NodeId) - --- Instances ------------- - -instance Apply Edge where - apply subst (Edge from to) = Edge (apply subst from) (apply subst to) - -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 - - ------------------------------------------------------------------------------- --- Goals ------------------------------------------------------------------------------- - --- | A 'Goal' denotes that a constraint reduction rule is applicable, which --- might result in case splits. We either use a heuristic to decide what goal --- to solve next or leave the choice to user (in case of the interactive UI). -data Goal = - ActionG LVar LNFact - -- ^ An action that must exist in the trace. - | ChainG NodeConc NodePrem - -- A destruction chain. - | PremiseG NodePrem LNFact - -- ^ A premise that must have an incoming direct edge. - | SplitG SplitId - -- ^ A case split over equalities. - | DisjG (Disj LNGuarded) - -- ^ A case split over a disjunction. - deriving( Eq, Ord, Show ) - --- Indicators -------------- - -isActionGoal :: Goal -> Bool -isActionGoal (ActionG _ _) = True -isActionGoal _ = False - -isStandardActionGoal :: Goal -> Bool -isStandardActionGoal (ActionG _ fa) = not (isKUFact fa) -isStandardActionGoal _ = False - -isPremiseGoal :: Goal -> Bool -isPremiseGoal (PremiseG _ _) = True -isPremiseGoal _ = 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 <> foldFrees f fa - PremiseG p fa -> foldFrees f p <> foldFrees f fa - ChainG c p -> foldFrees f c <> foldFrees f p - SplitG i -> foldFrees f i - DisjG 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 - ChainG c p -> ChainG <$> mapFrees f c <*> mapFrees f p - SplitG i -> SplitG <$> mapFrees f i - DisjG x -> DisjG <$> 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) - ChainG c p -> ChainG (apply subst c) (apply subst p) - SplitG i -> SplitG (apply subst i) - DisjG x -> DisjG (apply subst x) - - ------------------------------------------------------------------------------- --- Pretty printing -- ------------------------------------------------------------------------------- - --- | Pretty print a node. -prettyNode :: HighlightDocument d => (NodeId, RuleACInst) -> d -prettyNode (v,ru) = prettyNodeId v <> colon <-> prettyRuleACInst ru - --- | Pretty print a node conclusion. -prettyNodeConc :: HighlightDocument d => NodeConc -> d -prettyNodeConc (v, ConcIdx i) = parens (prettyNodeId v <> comma <-> int i) - --- | Pretty print a node premise. -prettyNodePrem :: HighlightDocument d => NodePrem -> d -prettyNodePrem (v, PremIdx i) = parens (prettyNodeId v <> comma <-> int i) - --- | Pretty print a edge as @src >-i--j-> tgt@. -prettyEdge :: HighlightDocument d => Edge -> d -prettyEdge (Edge c p) = - prettyNodeConc c <-> operator_ ">-->" <-> prettyNodePrem p - --- | Pretty print a less-atom as @src < tgt@. -prettyLess :: HighlightDocument d => Less -> d -prettyLess (i, j) = prettyNAtom $ Less (varTerm i) (varTerm j) - --- | Pretty print a goal. -prettyGoal :: HighlightDocument d => Goal -> d -prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa) -prettyGoal (ChainG c p) = - prettyNodeConc c <-> operator_ "~~>" <-> prettyNodePrem p -prettyGoal (PremiseG (i, (PremIdx v)) fa) = - -- Note that we can use "▷" for conclusions once we need them. - prettyLNFact fa <-> text ("▶" ++ subscript (show v)) <-> prettyNodeId i - -- prettyNodePrem p <> brackets (prettyLNFact fa) -prettyGoal (DisjG (Disj [])) = text "Disj" <-> operator_ "(⊥)" -prettyGoal (DisjG (Disj gfs)) = fsep $ - punctuate (operator_ " ∥") (map (nest 1 . parens . prettyGuarded) gfs) - -- punctuate (operator_ " |") (map (nest 1 . parens . prettyGuarded) gfs) -prettyGoal (SplitG x) = - text "splitEqs" <> parens (text $ show (unSplitId x)) - --- Derived instances --------------------- - -$( derive makeBinary ''Edge) -$( derive makeBinary ''Goal) - -$( derive makeNFData ''Edge) -$( derive makeNFData ''Goal) diff --git a/src/Theory/Constraint/System/Dot.hs b/src/Theory/Constraint/System/Dot.hs deleted file mode 100644 --- a/src/Theory/Constraint/System/Dot.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} --- | --- Copyright : (c) 2010, 2011 Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Conversion of the graph part of a sequent to a Graphviz Dot file. -module Theory.Constraint.System.Dot ( - nonEmptyGraph - , dotSystemLoose - , dotSystemCompact - , compressSystem - , BoringNodeStyle(..) - ) where - -import Data.Char (isSpace) -import Data.Color -import qualified Data.DAG.Simple as D -import qualified Data.Foldable as F -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid (Any(..)) -import qualified Data.Set as S -import Safe - -import Extension.Data.Label -import Extension.Prelude - -import Control.Basics -import Control.Monad.Reader -import Control.Monad.State (StateT, evalStateT) - -import qualified Text.Dot as D -import Text.PrettyPrint.Class - -import Theory.Constraint.System -import Theory.Model -import Theory.Text.Pretty (opAction) - --- | 'True' iff the dotted system will be a non-empty graph. -nonEmptyGraph :: System -> Bool -nonEmptyGraph sys = not $ - M.null (get sNodes sys) && null (unsolvedActionAtoms sys) && - null (unsolvedChains sys) && - S.null (get sEdges sys) && S.null (get sLessAtoms sys) - -type NodeColorMap = M.Map (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) (HSV Double) -type SeDot = ReaderT (System, NodeColorMap) (StateT DotState D.Dot) - --- | State to avoid multiple drawing of the same entity. -data DotState = DotState { - _dsNodes :: M.Map NodeId D.NodeId - , _dsPrems :: M.Map NodePrem D.NodeId - , _dsConcs :: M.Map NodeConc D.NodeId - , _dsSingles :: M.Map (NodeConc, NodePrem) D.NodeId - } - -$(mkLabels [''DotState]) - --- | Lift a 'D.Dot' action. -liftDot :: D.Dot a -> SeDot a -liftDot = lift . lift - --- | All edges in a bipartite graph that have neither start point nor endpoint --- in common with any other edge. -singleEdges :: (Ord a, Ord b) => [(a,b)] -> [(a,b)] -singleEdges es = - singles fst es `intersect` singles snd es - where - singles proj = concatMap single . groupOn proj . sortOn proj - single [] = error "impossible" - single [x] = return x - single _ = mzero - --- | Get a lighter color. -lighter :: HSV Double -> RGB Double -lighter = hsvToRGB -- fmap (\c -> 1 - 0.3*(1-c)) . hsvToRGB - --- | Ensure that a 'SeDot' action is only executed once by querying and --- updating the 'DotState' accordingly. -dotOnce :: Ord k - => (DotState :-> M.Map k D.NodeId) -- ^ Accessor to map storing this type of actions. - -> k -- ^ Action index. - -> SeDot D.NodeId -- ^ Action to execute only once. - -> SeDot D.NodeId -dotOnce mapL k dot = do - i <- join $ (maybe dot return . M.lookup k) `liftM` getM mapL - modM mapL (M.insert k i) - return i - -dotNode :: NodeId -> SeDot D.NodeId -dotNode v = dotOnce dsNodes v $ do - (se, colorMap) <- ask - let nodes = get sNodes se - dot info moreStyle facts = do - vId <- liftDot $ D.node $ [("label", show v ++ info),("shape","ellipse")] - ++ moreStyle - _ <- facts vId - return vId - - case M.lookup v nodes of - Nothing -> do - dot "" [] (const $ return ()) -- \vId -> do - {- - premIds <- mapM dotPrem - [ NodePremFact v fa - | SeRequires v' fa <- S.toList $ get sRequires se - , v == v' ] - sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ] - -} - Just ru -> do - let - color = M.lookup (get rInfo ru) colorMap - nodeColor = maybe "white" (rgbToHex . lighter) color - dot (label ru) [("fillcolor", nodeColor),("style","filled")] $ \vId -> do - premIds <- mapM dotPrem - [ (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 . 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. -dotIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot () -dotIntraRuleEdge from to = liftDot $ D.edge from to [("color","gray")] - -{- --- | An edge from a rule node to some of its premises or conclusions. -dotNonFixedIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot () -dotNonFixedIntraRuleEdge from to = - liftDot $ D.edge from to [("color","steelblue")] --} - --- | The style of a node displaying a fact. -factNodeStyle :: LNFact -> [(String,String)] -factNodeStyle fa - | isJust (kFactView fa) = [] - | otherwise = [("fillcolor","gray85"),("style","filled")] - --- | An edge that shares no endpoints with another edge and is therefore --- contracted. --- --- FIXME: There may be too many edges being contracted. -dotSingleEdge :: (NodeConc, NodePrem) -> SeDot D.NodeId -dotSingleEdge edge@(_, to) = dotOnce dsSingles edge $ do - se <- asks fst - let fa = nodePremFact to se - label = render $ prettyLNFact fa - liftDot $ D.node $ [("label", label),("shape", "hexagon")] - ++ factNodeStyle fa - --- | A compressed edge. -dotTrySingleEdge :: Eq c - => ((NodeConc, NodePrem) -> c) -> c - -> SeDot D.NodeId -> SeDot D.NodeId -dotTrySingleEdge sel x dot = do - singles <- getM dsSingles - maybe dot (return . snd) $ find ((x ==) . sel . fst) $ M.toList singles - --- | Premises. -dotPrem :: NodePrem -> SeDot D.NodeId -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 <- lookupPrem i ru - return ( render $ prettyLNFact fa - , factNodeStyle fa - ) - liftDot $ D.node $ [("label", label),("shape",shape)] - ++ moreStyle - where - shape = "invtrapezium" - --- | Conclusions. -dotConc :: NodeConc -> SeDot D.NodeId -dotConc = - dotNodeWithIndex dsConcs fst rConcs (id *** getConcIdx) "trapezium" - where - dotNodeWithIndex stateSel edgeSel ruleSel unwrap shape x0 = - dotOnce stateSel x0 $ dotTrySingleEdge edgeSel x0 $ do - let x = unwrap x0 - nodes <- asks (get sNodes . fst) - let (label, moreStyle) = fromMaybe (show x, []) $ do - ru <- M.lookup (fst x) nodes - fa <- (`atMay` snd x) $ get ruleSel ru - return ( render $ prettyLNFact fa - , factNodeStyle fa - ) - liftDot $ D.node $ [("label", label),("shape",shape)] - ++ moreStyle - - - --- | Convert the sequent to a 'D.Dot' action representing this sequent as a --- graph in the GraphViz format. The style is loose in the sense that each --- premise and conclusion gets its own node. -dotSystemLoose :: System -> D.Dot () -dotSystemLoose se = - (`evalStateT` DotState M.empty M.empty M.empty M.empty) $ - (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do - liftDot $ setDefaultAttributes - -- draw single edges with matching facts. - mapM_ dotSingleEdge $ singleEdges $ do - Edge from to <- S.toList $ get sEdges se - -- FIXME: ensure that conclusion and premise are equal - guard (nodeConcFact from se == nodePremFact to se) - return (from, to) - sequence_ $ do - (v, ru) <- M.toList $ get sNodes se - (i, _) <- enumConcs ru - return (dotConc (v, i)) - sequence_ $ do - (v, ru) <- M.toList $ get sNodes se - (i, _) <- enumPrems ru - return (dotPrem (v,i)) - -- FIXME: Also dot unsolved actions. - mapM_ dotNode $ M.keys $ get sNodes se - mapM_ dotEdge $ S.toList $ get sEdges se - mapM_ dotChain $ unsolvedChains se - mapM_ dotLess $ S.toList $ get sLessAtoms se - where - dotEdge (Edge src tgt) = do - mayNid <- M.lookup (src,tgt) `liftM` getM dsSingles - maybe (dotGenEdge [] src tgt) (const $ return ()) mayNid - - dotChain (src, tgt) = - dotGenEdge [("style","dashed"),("color","green")] src tgt - - dotLess (src, tgt) = do - srcId <- dotNode src - tgtId <- dotNode tgt - liftDot $ D.edge srcId tgtId - [("color","black"),("style","dotted")] -- FIXME: Reactivate,("constraint","false")] - -- setting constraint to false ignores less-edges when ranking nodes. - - dotGenEdge style src tgt = do - srcId <- dotConc src - tgtId <- dotPrem tgt - liftDot $ D.edge srcId tgtId style - - --- | Set default attributes for nodes and edges. -setDefaultAttributes :: D.Dot () -setDefaultAttributes = do - D.attribute ("nodesep","0.3") - D.attribute ("ranksep","0.3") - D.nodeAttributes [("fontsize","8"),("fontname","Helvetica"),("width","0.3"),("height","0.2")] - D.edgeAttributes [("fontsize","8"),("fontname","Helvetica")] - - --- | Compute a color map for nodes labelled with a proof rule info of one of --- the given rules. -nodeColorMap :: [RuleACInst] -> NodeColorMap -nodeColorMap rules = - M.fromList $ - [ (get rInfo ru, getColor (gIdx, mIdx)) - | (gIdx, grp) <- groups, (mIdx, ru) <- zip [0..] grp ] - where - groupIdx ru | isDestrRule ru = 0 - | isConstrRule ru = 2 - | isFreshRule ru || isISendRule ru = 3 - | otherwise = 1 - - -- groups of rules labeled with their index in the group - groups = [ (gIdx, [ ru | ru <- rules, gIdx == groupIdx ru]) - | gIdx <- [0..3] - ] - - -- color for each member of a group - colors = M.fromList $ lightColorGroups intruderHue (map (length . snd) groups) - getColor idx = fromMaybe (HSV 0 1 1) $ M.lookup idx colors - - -- The hue of the intruder rules - intruderHue :: Double - intruderHue = 18 / 360 - ------------------------------------------------------------------------------- --- 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 :: 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 ] - case M.lookup v $ get sNodes se of - Nothing -> case filter ((v ==) . fst) (unsolvedActionAtoms se) of - [] -> mkSimpleNode (show v) [] - as -> let lbl = (fsep $ punctuate comma $ map (prettyLNFact . snd) as) - <-> opAction <-> text (show v) - attrs | any (isKUFact . snd) as = [("color","gray")] - | otherwise = [("color","darkblue")] - in mkSimpleNode (render lbl) attrs - Just ru -> do - let color = M.lookup (get rInfo ru) colorMap - nodeColor = maybe "white" (rgbToHex . lighter) color - attrs = [("fillcolor", nodeColor),("style","filled")] - 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 - - 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 - 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), if there is anything --- to draw. -dotSystemCompact :: BoringNodeStyle -> System -> D.Dot () -dotSystemCompact 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 boringStyle) $ M.keys $ get sNodes se - mapM_ (dotNodeCompact boringStyle . fst) $ unsolvedActionAtoms se - F.mapM_ dotEdge $ get sEdges se - F.mapM_ dotChain $ unsolvedChains se - F.mapM_ dotLess $ get sLessAtoms se - where - missingNode shape label = liftDot $ D.node $ [("label", render label),("shape",shape)] - dotPremC prem = dotOnce dsPrems prem $ missingNode "invtrapezium" $ prettyNodePrem prem - dotConcC conc = dotOnce dsConcs conc $ missingNode "trapezium" $ prettyNodeConc conc - 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")] ++ - (guard (check isPersistentFact) >> [("color","gray50")]) - | check isKFact = [("color","orangered2")] - | otherwise = [("color","gray30")] - dotGenEdge attrs src tgt - - dotGenEdge style src tgt = do - srcId <- dotConcC src - tgtId <- dotPremC tgt - liftDot $ D.edge srcId tgtId style - - dotChain (src, tgt) = - dotGenEdge [("style","dashed"),("color","green")] src tgt - - dotLess (src, tgt) = do - srcId <- dotNodeCompact boringStyle src - tgtId <- dotNodeCompact boringStyle tgt - liftDot $ D.edge srcId tgtId - [("color","black"),("style","dotted")] -- FIXME: reactivate ,("constraint","false")] - -- setting constraint to false ignores less-edges when ranking nodes. - - ------------------------------------------------------------------------------- --- Compressed versions of a sequent ------------------------------------------------------------------------------- - --- | Drop 'Less' atoms entailed by the edges of the 'System'. -dropEntailedOrdConstraints :: System -> System -dropEntailedOrdConstraints se = - modify sLessAtoms (S.filter (not . entailed)) se - where - edges = rawEdgeRel se - entailed (from, to) = to `S.member` D.reachableSet [from] edges - --- | Unsound compression of the sequent that drops fully connected learns and --- knows nodes. -compressSystem :: System -> System -compressSystem se0 = - foldl' (flip tryHideNodeId) se (frees (get sLessAtoms se, get sNodes se)) - 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 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. -tryHideNodeId :: NodeId -> System -> System -tryHideNodeId v se = fromMaybe se $ do - guard $ (lvarSort v == LSortNode) - && notOccursIn unsolvedChains - && notOccursIn (get sFormulas) - maybe hideAction hideRule (M.lookup v $ get sNodes se) - where - selectPart :: (System :-> S.Set a) -> (a -> Bool) -> [a] - selectPart l p = filter p $ S.toList $ get l se - - notOccursIn :: HasFrees a => (System -> a) -> Bool - notOccursIn proj = not $ getAny $ foldFrees (Any . (v ==)) $ proj se - - -- hide KU-actions deducing pairs, inverses, and simple terms - hideAction = do - guard $ not (null kuActions) - && all eligibleTerm kuActions - && all (\(i, j) -> not (i == j)) lNews - && notOccursIn (standardActionAtoms) - && notOccursIn (get sLastAtom) - && notOccursIn (get sEdges) - - return $ modify sLessAtoms ( (`S.union` S.fromList lNews) - . (`S.difference` S.fromList lIns) - . (`S.difference` S.fromList lOuts) - ) - $ modify sGoals (\m -> foldl' removeAction m kuActions) - $ se - where - kuActions = [ x | x@(i,_,_) <- kuActionAtoms se, i == v ] - eligibleTerm (_,_,m) = - isPair m || isInverse m || sortOfLNTerm m == LSortPub - - removeAction m (i, fa, _) = M.delete (ActionG i fa) m - - lIns = selectPart sLessAtoms ((v ==) . snd) - lOuts = selectPart sLessAtoms ((v ==) . fst) - lNews = [ (i, j) | (i, _) <- lIns, (_, j) <- lOuts ] - - -- hide a rule, if it is not "too complicated" - hideRule ru = do - guard $ eligibleRule - && ( length eIns == length (get rPrems ru) ) - && ( length eOuts == length (get rConcs ru) ) - && ( all (not . selfEdge) eNews ) - && notOccursIn (get sLastAtom) - && notOccursIn (get sLessAtoms) - && notOccursIn (unsolvedActionAtoms) - - return $ modify sEdges ( (`S.union` S.fromList eNews) - . (`S.difference` S.fromList eIns) - . (`S.difference` S.fromList eOuts) - ) - $ modify sNodes (M.delete v) - $ se - where - eIns = selectPart sEdges ((v ==) . nodePremNode . eTgt) - eOuts = selectPart sEdges ((v ==) . nodeConcNode . eSrc) - eNews = [ Edge cIn pOut | Edge cIn _ <- eIns, Edge _ pOut <- eOuts ] - - selfEdge (Edge cIn pOut) = nodeConcNode cIn == nodePremNode pOut - - eligibleRule = - any ($ ru) [isISendRule, isIRecvRule, isCoerceRule, isFreshRule] - || ( null (get rActs ru) && - all (\l -> length (get l ru) <= 1) [rPrems, rConcs] - ) - -{- --- | Try to hide a 'NodeId'. This only works if it has only action and either --- edge or less constraints associated. -tryHideNodeId :: NodeId -> System -> System --} - diff --git a/src/Theory/Constraint/System/Guarded.hs b/src/Theory/Constraint/System/Guarded.hs deleted file mode 100644 --- a/src/Theory/Constraint/System/Guarded.hs +++ /dev/null @@ -1,650 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | --- Copyright : (c) 2011 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Benedikt Schmidt --- Portability : GHC only --- --- Guarded formulas. -module Theory.Constraint.System.Guarded ( - - -- * Guarded formulas - Guarded(..) - , LGuarded - , LNGuarded - - -- ** Smart constructors - , gfalse - , gtrue - , gdisj - , gconj - , gex - , gall - , gnot - , ginduct - - , formulaToGuarded - , formulaToGuarded_ - - -- ** Transformation - , simplifyGuarded - - , mapGuardedAtoms - - -- ** Queries - , isConjunction - , isDisjunction - , isAllGuarded - , isExGuarded - , isSafetyFormula - - , guardFactTags - - -- ** Conversions to non-bound representations - , bvarToLVar - , openGuarded - - -- ** Substitutions - , substBound - , substBoundAtom - , substFree - , substFreeAtom - - -- ** Pretty-printing - , prettyGuarded - - ) where - -import Control.Applicative -import Control.Arrow -import Control.DeepSeq -import Control.Monad.Error -import Control.Monad.Fresh (MonadFresh, scopeFreshness) -import qualified Control.Monad.Trans.PreciseFresh as Precise (Fresh, evalFresh, evalFreshT) - -import Debug.Trace - -import Data.Binary -import Data.DeriveTH -import Data.Either (partitionEithers) -import Data.Foldable (Foldable(..), foldMap) -import Data.List -import qualified Data.DList as D -import Data.Monoid (Monoid(..)) -import Data.Traversable hiding (mapM, sequence) - -import Logic.Connectives - -import Text.PrettyPrint.Highlight - -import Theory.Model - - ------------------------------------------------------------------------------- --- Types ------------------------------------------------------------------------------- - -data Guarded s c v = GAto (Atom (VTerm c (BVar v))) - | GDisj (Disj (Guarded s c v)) - | GConj (Conj (Guarded s c v)) - | GGuarded Quantifier [s] [Atom (VTerm c (BVar v))] (Guarded s c v) - -- ^ Denotes @ALL xs. as => gf@ or @Ex xs. as & gf& - -- depending on the 'Quantifier'. - -- We assume that all bound variables xs occur in - -- f@i atoms in as. - deriving (Eq, Ord, Show) - -isConjunction :: Guarded s c v -> Bool -isConjunction (GConj _) = True -isConjunction _ = False - -isDisjunction :: Guarded s c v -> Bool -isDisjunction (GDisj _) = True -isDisjunction _ = False - -isExGuarded :: Guarded s c v -> Bool -isExGuarded (GGuarded Ex _ _ _) = True -isExGuarded _ = False - -isAllGuarded :: Guarded s c v -> Bool -isAllGuarded (GGuarded All _ _ _) = True -isAllGuarded _ = False - --- | Check whether the guarded formula is closed and does not contain an --- existential quantifier. This under-approximates the question whether the --- formula is a safety formula. A safety formula @phi@ has the property that a --- trace violating it can never be extended to a trace satisfying it. -isSafetyFormula :: HasFrees (Guarded s c v) => Guarded s c v -> Bool -isSafetyFormula gf0 = - null (frees [gf0]) && noExistential gf0 - where - noExistential (GAto _ ) = True - noExistential (GGuarded Ex _ _ _) = False - noExistential (GGuarded All _ _ gf) = noExistential gf - noExistential (GDisj disj) = all noExistential $ getDisj disj - noExistential (GConj conj) = all noExistential $ getConj conj - --- | All 'FactTag's that are used in guards. -guardFactTags :: Guarded s c v -> [FactTag] -guardFactTags = - D.toList . - foldGuarded mempty (mconcat . getDisj) (mconcat . getConj) getTags - where - getTags _qua _ss atos inner = - mconcat [ D.singleton tag | Action _ (Fact tag _) <- atos ] <> inner - ------------------------------------------------------------------------------- --- Folding ------------------------------------------------------------------------------- - - --- | Fold a guarded formula. -foldGuarded :: (Atom (VTerm c (BVar v)) -> b) - -> (Disj b -> b) - -> (Conj b -> b) - -> (Quantifier -> [s] -> [Atom (VTerm c (BVar v))] -> b -> b) - -> Guarded s c v - -> b -foldGuarded fAto fDisj fConj fGuarded = - go - where - go (GAto a) = fAto a - go (GDisj disj) = fDisj $ fmap go disj - go (GConj conj) = fConj $ fmap go conj - go (GGuarded qua ss as gf) = fGuarded qua ss as (go gf) - --- | Fold a guarded formula with scope info. --- The Integer argument denotes the number of --- quantifiers that have been encountered so far. -foldGuardedScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) - -> (Disj b -> b) - -> (Conj b -> b) - -> (Quantifier -> [s] -> Integer -> [Atom (VTerm c (BVar v))] -> b -> b) - -> Guarded s c v - -> b -foldGuardedScope fAto fDisj fConj fGuarded = - go 0 - where - go !i (GAto a) = fAto i a - go !i (GDisj disj) = fDisj $ fmap (go i) disj - go !i (GConj conj) = fConj $ fmap (go i) conj - go !i (GGuarded qua ss as gf) = - fGuarded qua ss i' as (go i' gf) - where - i' = i + fromIntegral (length ss) - - --- | Map a guarded formula with scope info. --- The Integer argument denotes the number of --- quantifiers that have been encountered so far. -mapGuardedAtoms :: (Integer -> Atom (VTerm c (BVar v)) - -> Atom (VTerm d (BVar w))) - -> Guarded s c v - -> Guarded s d w -mapGuardedAtoms f = - foldGuardedScope (\i a -> GAto $ f i a) GDisj GConj - (\qua ss i as gf -> GGuarded qua ss (map (f i) as) gf) - ------------------------------------------------------------------------------- --- Instances ------------------------------------------------------------------------------- - -{- -instance Functor (Guarded s c) where - 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)))) - (mconcat . getDisj) - (mconcat . getConj) - (\_qua _ss as b -> foldMap (foldMap (foldMap (foldMap (foldMap f)))) as `mappend` b) - -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 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? -type LGuarded c = Guarded (String, LSort) c LVar - ------------------------------------------------------------------------------- --- Substitutions of bound for free and vice versa ------------------------------------------------------------------------------- - --- | @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 :: 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 - subst fv = fv - --- | @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 :: 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 :: Ord c - => [(LVar,Integer)] - -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar)) -substFreeAtom s = fmap (fmapTerm (fmap subst)) - where subst fv@(Free x) = case lookup x s of - Just i -> Bound i - Nothing -> fv - subst bv = bv - --- | @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 :: 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 :: Ord c => Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar) -bvarToLVar = - fmap (fmapTerm (fmap (foldBVar boundError id))) - where - boundError v = error $ "bvarToLVar: left-over bound variable '" - ++ show v ++ "'" - --- | Provided an 'Atom' does not contain a bound variable, it is converted to --- the type of atoms without bound varaibles. -unbindAtom :: (Ord c, Ord v) => Atom (VTerm c (BVar v)) -> Maybe (Atom (VTerm c v)) -unbindAtom = traverse (traverseTerm (traverse (foldBVar (const Nothing) Just))) - - ------------------------------------------------------------------------------- --- Opening and Closing ------------------------------------------------------------------------------- - --- | @openGuarded gf@ returns @Just (qua,vs,ats,gf')@ if @gf@ is a guarded --- clause and @Nothing@ otherwise. In the first case, @quao@ is the quantifier, --- @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 :: (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 - return $ Just (qua, xs, openas xs, opengf xs) - where - openas xs = map (bvarToLVar . substBoundAtom (subst xs)) as - opengf xs = substBound (subst xs) gf - subst xs = zip [0..] (reverse xs) -openGuarded _ = return Nothing - --- | @closeGuarded vs ats gf@ is a smart constructor for @GGuarded@. -closeGuarded :: Ord c => Quantifier -> [LVar] -> [Atom (VTerm c LVar)] - -> LGuarded c -> LGuarded c -closeGuarded qua vs as gf = - (case qua of Ex -> gex; All -> gall) vs' as' gf' - where - as' = map (substFreeAtom s . fmap (fmapTerm (fmap Free))) as - gf' = substFree s gf - s = zip (reverse vs) [0..] - vs' = map (lvarName &&& lvarSort) vs - - ------------------------------------------------------------------------------- --- Conversion and negation ------------------------------------------------------------------------------- - -type LNGuarded = Guarded (String,LSort) Name LVar - -instance Apply LNGuarded where - apply subst = mapGuardedAtoms (const $ apply subst) - - --- | @gtf b@ returns the guarded formula f with @b <-> f@. -gtf :: Bool -> Guarded s c v -gtf False = GDisj (Disj []) -gtf True = GConj (Conj []) - --- | @gfalse@ returns the guarded formula f with @False <-> f@. -gfalse :: Guarded s c v -gfalse = gtf False - --- | @gtrue@ returns the guarded formula f with @True <-> f@. -gtrue :: Guarded s c v -gtrue = gtf True - --- | @gnotAtom a@ returns the guarded formula f with @not a <-> f@. -gnotAtom :: Atom (VTerm c (BVar v)) -> Guarded s c v -gnotAtom a = GGuarded All [] [a] gfalse - --- | @gconj gfs@ smart constructor for the conjunction of gfs. -gconj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v -gconj gfs0 = case concatMap flatten gfs0 of - [gf] -> gf - gfs | any (gfalse ==) gfs -> gfalse - -- FIXME: See 'sortednub' below. - | otherwise -> GConj $ Conj $ nub gfs - where - flatten (GConj conj) = concatMap flatten $ getConj conj - flatten gf = [gf] - --- | @gdisj gfs@ smart constructor for the disjunction of gfs. -gdisj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v -gdisj gfs0 = case concatMap flatten gfs0 of - [gf] -> gf - gfs | any (gtrue ==) gfs -> gtrue - -- FIXME: Consider using 'sortednub' here. This yields stronger - -- normalizaton for formulas. However, it also means that we loose - -- invariance under renaming free variables, as the order changes, - -- when they are renamed. - | otherwise -> GDisj $ Disj $ nub gfs - where - flatten (GDisj disj) = concatMap flatten $ getDisj disj - flatten gf = [gf] - --- @ A smart constructor for @GGuarded Ex@ that removes empty quantifications --- and conjunctions with 'gfalse'. -gex :: (Ord s, Ord c, Ord v) - => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v -gex [] as gf = gconj (map GAto as ++ [gf]) -gex _ _ gf | gf == gfalse = gfalse -gex ss as gf = GGuarded Ex ss as gf - --- @ A smart constructor for @GGuarded All@ that drops implications to 'gtrue' --- and removes empty premises. -gall :: (Eq s, Eq c, Eq v) - => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v -gall _ [] gf = gf -gall _ _ gf | gf == gtrue = gtrue -gall ss atos gf = GGuarded All ss atos gf - - --- Conversion of formulas to guarded formulas ---------------------------------------------- - --- | Local newtype to avoid orphan instance. -newtype ErrorDoc d = ErrorDoc { unErrorDoc :: d } - deriving( Monoid, NFData, Document, HighlightDocument ) - -instance Document d => Error (ErrorDoc d) where - noMsg = emptyDoc - strMsg = text - - --- | @formulaToGuarded fm@ returns a guarded formula @gf@ that is --- equivalent to @fm@ under the assumption that this is possible. --- If not, then 'error' is called. -formulaToGuarded_ :: LNFormula -> LNGuarded -formulaToGuarded_ = either (error . render) id . formulaToGuarded - --- | @formulaToGuarded fm@ returns a guarded formula @gf@ that is --- equivalent to @fm@ if possible. -formulaToGuarded :: HighlightDocument d => LNFormula -> Either d LNGuarded -formulaToGuarded fmOrig = - either (Left . ppError . unErrorDoc) Right - $ Precise.evalFreshT (convert False fmOrig) (avoidPrecise fmOrig) - where - ppFormula :: HighlightDocument a => LNFormula -> a - ppFormula = nest 2 . doubleQuotes . prettyLNFormula - - ppError d = d $-$ text "in the formula" $-$ ppFormula fmOrig - - convert True (Ato a) = pure $ gnotAtom a - convert False (Ato a) = pure $ GAto a - - convert polarity (Not f) = convert (not polarity) f - - convert True (Conn And f g) = gdisj <$> mapM (convert True) [f, g] - convert False (Conn And f g) = gconj <$> mapM (convert False) [f, g] - - convert True (Conn Or f g) = gconj <$> mapM (convert True) [f, g] - convert False (Conn Or f g) = gdisj <$> mapM (convert False) [f, g] - - convert True (Conn Imp f g ) = - gconj <$> sequence [convert False f, convert True g] - convert False (Conn Imp f g ) = - gdisj <$> sequence [convert True f, convert False g] - - convert polarity (TF b) = pure $ gtf (polarity /= b) - - convert polarity f0@(Qua qua0 _ _) = - -- The quantifier switch stems from our implicit negation of the formula. - case (qua0, polarity) of - (All, True ) -> convAll Ex - (All, False) -> convAll All - (Ex, True ) -> convEx All - (Ex, False) -> convEx Ex - where - noUnguardedVars [] = return () - noUnguardedVars unguarded = throwError $ vcat - [ fsep $ text "unguarded variable(s)" - : (punctuate comma $ - map (quotes . text . show) unguarded) - ++ map text ["in", "the", "subformula"] - , ppFormula f0 - ] - - conjActions (Conn And f1 f2) = conjActions f1 ++ conjActions f2 - conjActions (Ato a@(Action _ _)) = [Left $ bvarToLVar a] - conjActions f = [Right f] - - convEx qua = do - (xs,_,f) <- openFormulaPrefix f0 - case partitionEithers $ conjActions f of - (as, fs) -> do - -- all existentially quantified variables must be guarded - noUnguardedVars (xs \\ frees as) - -- convert all other formulas - gf <- (if polarity then gdisj else gconj) - <$> mapM (convert polarity) fs - return $ closeGuarded qua xs as gf - where - - convAll qua = do - (xs,_,f) <- openFormulaPrefix f0 - case f of - Conn Imp ante suc -> case partitionEithers $ conjActions ante of - (as, fs) -> do - -- all universally quantified variables must be guarded - noUnguardedVars (xs \\ frees as) - -- negate formulas in antecedent and combine with body - gf <- (if polarity then gconj else gdisj) - <$> sequence ( map (convert (not polarity)) fs ++ - [convert polarity suc] ) - - return $ closeGuarded qua xs as gf - - _ -> throwError $ - text "universal quantifier without toplevel implication" $-$ - ppFormula f0 - - convert polarity (Conn Iff f1 f2) = - gconj <$> mapM (convert polarity) [Conn Imp f1 f2, Conn Imp f2 f1] - - ------------------------------------------------------------------------------- --- Induction over the trace ------------------------------------------------------------------------------- - --- | Negate a guarded formula. -gnot :: (Ord s, Ord c, Ord v) - => Guarded s c v -> Guarded s c v -gnot = - go - where - go (GGuarded All ss as gf) = gex ss as $ go gf - go (GGuarded Ex ss as gf) = gall ss as $ go gf - go (GAto ato) = gnotAtom ato - go (GDisj disj) = gconj $ map go (getDisj disj) - go (GConj conj) = gdisj $ map go (getConj conj) - - --- | Checks if a doubly guarded formula is satisfied by the empty trace; --- returns @'Left' errMsg@ if the formula is not doubly guarded. -satisfiedByEmptyTrace :: Guarded s c v -> Either String Bool -satisfiedByEmptyTrace = - foldGuarded - (\_ato -> throwError "atom outside the scope of a quantifier") - (liftM or . sequence . getDisj) - (liftM and . sequence . getConj) - (\qua _ss _as _gf -> return $ qua == All) - -- the empty trace always satisfies guarded all-quantification - -- and always dissatisfies guarded ex-quantification - --- | Tries to convert a doubly guarded formula to an induction hypothesis. --- Returns @'Left' errMsg@ if the formula is not last-free or not doubly --- guarded. -toInductionHypothesis :: Ord c => LGuarded c -> Either String (LGuarded c) -toInductionHypothesis = - go - where - go (GGuarded qua ss as gf) - | any isLastAtom as = throwError "formula not last-free" - | otherwise = do - gf' <- go gf - return $ case qua of - All -> gex ss as (gconj $ (gnotAtom <$> lastAtos) ++ [gf']) - Ex -> gall ss as (gdisj $ (GAto <$> lastAtos) ++ [gf']) - where - lastAtos :: [Atom (VTerm c (BVar LVar))] - lastAtos = do - (j, (_, LSortNode)) <- zip [0..] $ reverse ss - return $ Last (varTerm (Bound j)) - - go (GAto (Less i j)) = return $ gdisj [GAto (EqE i j), GAto (Less j i)] - go (GAto (Last _)) = throwError "formula not last-free" - go (GAto ato) = return $ gnotAtom ato - go (GDisj disj) = gconj <$> traverse go (getDisj disj) - go (GConj conj) = gdisj <$> traverse go (getConj conj) - --- | Try to prove the formula by applying induction over the trace. --- Returns @'Left' errMsg@ if this is not possible. Returns a tuple of --- formulas: one formalzing the proof obligation of the base-case and one --- formalizing the proof obligation of the step-case. -ginduct :: Ord c => LGuarded c -> Either String (LGuarded c, LGuarded c) -ginduct gf = do - unless (null $ frees gf) (throwError "formula not closed") - unless (containsAction gf) (throwError "formula contains no action atom") - baseCase <- satisfiedByEmptyTrace gf - gfIH <- toInductionHypothesis gf - return (gtf baseCase, gconj [gf, gfIH]) - where - containsAction = foldGuarded (const True) (or . getDisj) (or . getConj) - (\_ _ as body -> not (null as) || body) - ------------------------------------------------------------------------------- --- Formula Simplification ------------------------------------------------------------------------------- - --- | Simplify a 'Guarded' formula by replacing atoms with their truth value, --- if it can be determined. -simplifyGuarded :: (LNAtom -> Maybe Bool) - -- ^ Partial assignment for truth value of atoms. - -> LNGuarded - -- ^ Original formula - -> Maybe LNGuarded - -- ^ Simplified formula, provided some simplification was - -- performed. -simplifyGuarded valuation fm0 - | fm1 /= fm0 = trace (render ppMsg) (Just fm1) - | otherwise = Nothing - where - ppFm = nest 2 . doubleQuotes . prettyGuarded - ppMsg = nest 2 $ text "simplified formula:" $-$ - nest 2 (vcat [ ppFm fm0, text "to", ppFm fm1]) - - fm1 = simp fm0 - - simp fm@(GAto ato) = maybe fm gtf (valuation =<< unbindAtom ato) - simp (GDisj fms) = gdisj $ map simp $ getDisj fms - simp (GConj fms) = gconj $ map simp $ getConj fms - simp (GGuarded All [] atos gf) - | any ((Just False ==) . snd) annAtos = gtrue - | otherwise = - -- keep all atoms that we cannot evaluate yet. - -- NOTE: Here we are missing the opportunity to change the valuation - -- for evaluating the body 'gf'. We could add all atoms that we have - -- as a premise. - gall [] (fst <$> filter ((Nothing ==) . snd) annAtos) (simp gf) - where - -- cache the possibly expensive evaluation of the valuation - annAtos = (\x -> (x, valuation =<< unbindAtom x)) <$> atos - - -- Note that existentials without quantifiers are already eliminated by - -- 'gex'. Moreover, we dealay simplification inside guarded all - -- quantification and guarded existential quantifiers. Their body will be - -- simplified once the quantifiers are gone. - simp fm@(GGuarded _ _ _ _) = fm - - ------------------------------------------------------------------------------- --- Pretty Printing ------------------------------------------------------------------------------- - --- | Pretty print a formula. -prettyGuarded :: HighlightDocument d - => LNGuarded -- ^ Guarded Formula. - -> d -- ^ Pretty printed formula. -prettyGuarded fm = - Precise.evalFresh (pp fm) (avoidPrecise fm) - where - pp :: HighlightDocument d => LNGuarded -> Precise.Fresh d - pp (GAto a) = return $ prettyNAtom $ bvarToLVar a - - pp (GDisj (Disj [])) = return $ operator_ "⊥" -- "F" - - pp (GDisj (Disj xs)) = do - ps <- mapM (\x -> opParens <$> pp x) xs - return $ sep $ punctuate (operator_ " ∨") ps - -- return $ sep $ punctuate (operator_ " |") ps - - pp (GConj (Conj [])) = return $ operator_ "⊤" -- "T" - - pp (GConj (Conj xs)) = do - ps <- mapM (\x -> opParens <$> pp x) xs - return $ sep $ punctuate (operator_ " ∧") ps --- " &") ps - - pp gf0@(GGuarded _ _ _ _) = - -- variable names invented here can be reused otherwise - scopeFreshness $ do - Just (qua, vs, atoms, gf) <- openGuarded gf0 - let antecedent = (GAto . fmap (fmapTerm (fmap Free))) <$> atoms - connective = operator_ (case qua of All -> "⇒"; Ex -> "∧") - -- operator_ (case qua of All -> "==>"; Ex -> "&") - quantifier = operator_ (ppQuant qua) <-> ppVars vs <> operator_ "." - dante <- nest 1 <$> pp (GConj (Conj antecedent)) - case (qua, vs, gf) of - (Ex, _, GConj (Conj [])) -> - return $ sep $ [ quantifier, dante ] - (All, [], GDisj (Disj [])) | gf == gfalse -> - return $ operator_ "¬" <> dante - _ -> do - dsucc <- nest 1 <$> pp gf - return $ sep [ quantifier, sep [dante, connective, dsucc] ] - where - ppVars = fsep . map (text . show) - ppQuant All = "∀" -- "All " - ppQuant Ex = "∃" -- "Ex " - - --- Derived instances --------------------- - -$( derive makeBinary ''Guarded) -$( derive makeNFData ''Guarded) diff --git a/src/Theory/Model.hs b/src/Theory/Model.hs deleted file mode 100644 --- a/src/Theory/Model.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | --- Copyright : (c) 2011-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Security protocol model. -module Theory.Model ( - module Term.Unification - , module Theory.Model.Atom - , module Theory.Model.Fact - , module Theory.Model.Formula - , module Theory.Model.Rule - , module Theory.Model.Signature - ) - where - -import Term.LTerm -import Term.Unification -import Theory.Model.Atom -import Theory.Model.Fact -import Theory.Model.Formula -import Theory.Model.Rule -import Theory.Model.Signature diff --git a/src/Theory/Model/Atom.hs b/src/Theory/Model/Atom.hs deleted file mode 100644 --- a/src/Theory/Model/Atom.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} --- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} --- {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE 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) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Formulas that represent security properties. -module Theory.Model.Atom( - - -- * Atoms - Atom(..) - , NAtom - , LNAtom - - , isActionAtom - , isLastAtom - , isLessAtom - , isEqAtom - - -- * LFormula - , BLAtom - - -- * Pretty-Printing - , prettyNAtom - ) -where - -import Control.Basics -import Control.DeepSeq - -import Data.Binary -import Data.DeriveTH -import Data.Foldable (Foldable, foldMap) -import Data.Generics -import Data.Monoid (mappend) -import Data.Traversable - -import Term.LTerm -import Term.Unification -import Theory.Model.Fact -import Theory.Text.Pretty - - ------------------------------------------------------------------------------- --- Atoms ------------------------------------------------------------------------------- - --- | @Atom@'s are the atoms of trace formulas parametrized over arbitrary --- terms. -data Atom t = Action t (Fact t) - | EqE t t - | Less t t - | Last t - deriving( Eq, Ord, Show, Data, Typeable ) - --- | @LAtom@ are the atoms we actually use in graph formulas input by the user. -type NAtom v = Atom (VTerm Name v) - --- | @LAtom@ are the atoms we actually use in graph formulas input by the user. -type LNAtom = Atom LNTerm - --- | Atoms built over 'BLTerm's. -type BLAtom = Atom BLTerm - - --- Instances ------------- - -instance Functor Atom where - fmap f (Action i fa) = Action (f i) (fmap f fa) - fmap f (EqE l r) = EqE (f l) (f r) - fmap f (Less v u) = Less (f v) (f u) - fmap f (Last i) = Last (f i) - -instance Foldable Atom where - foldMap f (Action i fa) = - f i `mappend` (foldMap f fa) - foldMap f (EqE l r) = f l `mappend` f r - foldMap f (Less i j) = f i `mappend` f j - foldMap f (Last i) = f i - -instance Traversable Atom where - traverse f (Action i fa) = - Action <$> f i <*> traverse f fa - traverse f (EqE l r) = EqE <$> f l <*> f r - traverse f (Less v u) = Less <$> f v <*> f u - traverse f (Last i) = Last <$> f i - -instance HasFrees t => HasFrees (Atom t) where - foldFrees f = foldMap (foldFrees f) - mapFrees f = traverse (mapFrees f) - -instance Apply LNAtom where - apply subst (Action i fact) = Action (apply subst i) (apply subst fact) - apply subst (EqE l r) = EqE (apply subst l) (apply subst r) - apply subst (Less i j) = Less (apply subst i) (apply subst j) - apply subst (Last i) = Last (apply subst i) - -instance Apply BLAtom where - apply subst (Action i fact) = Action (apply subst i) (apply subst fact) - apply subst (EqE l r) = EqE (apply subst l) (apply subst r) - apply subst (Less i j) = Less (apply subst i) (apply subst j) - apply subst (Last i) = Last (apply subst i) - - --- Queries ----------- - --- | True iff the atom is an action atom. -isActionAtom :: Atom t -> Bool -isActionAtom ato = case ato of Action _ _ -> True; _ -> False - --- | True iff the atom is a last atom. -isLastAtom :: Atom t -> Bool -isLastAtom ato = case ato of Last _ -> True; _ -> False - --- | True iff the atom is a temporal ordering atom. -isLessAtom :: Atom t -> Bool -isLessAtom ato = case ato of Less _ _ -> True; _ -> False - --- | True iff the atom is an equality atom. -isEqAtom :: Atom t -> Bool -isEqAtom ato = case ato of EqE _ _ -> True; _ -> False - - ------------------------------------------------------------------------------- --- Pretty-Printing ------------------------------------------------------------------------------- - -prettyNAtom :: (Show v, HighlightDocument d) => NAtom v -> d -prettyNAtom (Action v fa) = - prettyFact prettyNTerm fa <-> opAction <-> text (show v) -prettyNAtom (EqE l r) = - sep [prettyNTerm l <-> opEqual, prettyNTerm r] - -- sep [prettyNTerm l <-> text "≈", prettyNTerm r] -prettyNAtom (Less u v) = text (show u) <-> opLess <-> text (show v) -prettyNAtom (Last i) = operator_ "last" <> parens (text (show i)) - - --- derived instances --------------------- - -$( derive makeNFData ''Atom) -$( derive makeBinary ''Atom) diff --git a/src/Theory/Model/Fact.hs b/src/Theory/Model/Fact.hs deleted file mode 100644 --- a/src/Theory/Model/Fact.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2011, 2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Facts used to formulate and reason about protocol execution. -module Theory.Model.Fact ( - - -- * Fact - Fact(..) - , Multiplicity(..) - , FactTag(..) - - , matchFact - - -- ** Queries - , isLinearFact - , isPersistentFact - , isProtoFact - - , factTagName - , showFactTag - , showFactTagArity - , factTagArity - , factTagMultiplicity - , factArity - , factMultiplicity - - , DirTag(..) - , kuFact - , kdFact - , kFactView - , dedFactView - - , isKFact - , isKUFact - , isKDFact - - -- ** Construction - , freshFact - , outFact - , inFact - , kLogFact - , dedLogFact - , protoFact - - -- * NFact - , NFact - - -- * LFact - , LFact - , LNFact - , unifyLNFactEqs - , unifiableLNFacts - - -- * Pretty-Printing - - , prettyFact - , prettyNFact - , prettyLNFact - - ) where - -import Control.Basics -import Control.DeepSeq - -import Data.Binary -import Data.DeriveTH -import Data.Foldable (Foldable(..)) -import Data.Generics -import Data.Maybe (isJust) -import Data.Monoid -import Data.Traversable (Traversable(..)) - -import Term.Unification - -import Text.PrettyPrint.Class - - ------------------------------------------------------------------------------- --- Fact ------------------------------------------------------------------------------- - -data Multiplicity = Persistent | Linear - deriving( Eq, Ord, Show, Typeable, Data ) - --- | Fact tags/symbols -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. - | 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. -data Fact t = Fact - { factTag :: FactTag - , factTerms :: [t] - } - deriving( Eq, Ord, Show, Typeable, Data ) - - --- Instances ------------- - -instance Functor Fact where - fmap f (Fact tag ts) = Fact tag (fmap f ts) - -instance Foldable Fact where - foldMap f (Fact _ ts) = foldMap f ts - -instance Traversable Fact where - sequenceA (Fact tag ts) = Fact tag <$> sequenceA ts - traverse f (Fact tag ts) = Fact tag <$> traverse f ts - -instance Sized t => Sized (Fact t) where - size (Fact _ args) = size args - -instance HasFrees t => HasFrees (Fact t) where - foldFrees f = foldMap (foldFrees f) - mapFrees f = traverse (mapFrees f) - -instance Apply t => Apply (Fact t) where - apply subst = fmap (apply subst) - - --- KU and KD facts ------------------- - --- | A direction tag -data DirTag = UpK | DnK - deriving( Eq, Ord, Show ) - -kdFact, kuFact :: t -> Fact t -kdFact = Fact KDFact . return -kuFact = Fact KUFact . return - --- | View a message-deduction fact. -kFactView :: LNFact -> Maybe (DirTag, LNTerm) -kFactView fa = case fa of - Fact KUFact [m] -> Just (UpK, m) - Fact KUFact _ -> errMalformed "kFactView" fa - Fact KDFact [m] -> Just (DnK, m) - Fact KDFact _ -> errMalformed "kFactView" fa - _ -> Nothing - --- | 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 - --- | True if the fact is a KU-fact. -isKUFact :: LNFact -> Bool -isKUFact (Fact KUFact _) = True -isKUFact _ = False - --- | True if the fact is a KD-fact. -isKDFact :: LNFact -> Bool -isKDFact (Fact KDFact _) = True -isKDFact _ = False - --- | Mark a fact as malformed. -errMalformed :: String -> LNFact -> a -errMalformed caller fa = - error $ caller ++ show ": malformed fact: " ++ show fa - --- Constructing facts ---------------------- - --- | A fact denoting a message sent by the protocol to the intruder. -outFact :: t -> Fact t -outFact = Fact OutFact . return - --- | A fresh fact denotes a fresh unguessable name. -freshFact :: t -> Fact t -freshFact = Fact FreshFact . return - --- | A fact denoting that the intruder sent a message to the protocol. -inFact :: t -> Fact t -inFact = Fact InFact . return - --- | A fact logging that the intruder knows a message. -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 - - --- Queries on facts -------------------- - --- | True iff the fact is a non-special protocol fact. -isProtoFact :: Fact t -> Bool -isProtoFact (Fact (ProtoFact _ _ _) _) = True -isProtoFact _ = False - --- | True if the fact is a linear fact. -isLinearFact :: Fact t -> Bool -isLinearFact = (Linear ==) . factMultiplicity - --- | True if the fact is a persistent fact. -isPersistentFact :: Fact t -> Bool -isPersistentFact = (Persistent ==) . factMultiplicity - --- | The multiplicity of a 'FactTag'. -factTagMultiplicity :: FactTag -> Multiplicity -factTagMultiplicity tag = case tag of - ProtoFact multi _ _ -> multi - KUFact -> Persistent - KDFact -> Persistent - _ -> Linear - --- | The arity of a 'FactTag'. -factTagArity :: FactTag -> Int -factTagArity tag = case tag of - ProtoFact _ _ k -> k - KUFact -> 1 - KDFact -> 1 - DedFact -> 1 - FreshFact -> 1 - InFact -> 1 - OutFact -> 1 - --- | The arity of a 'Fact'. -factArity :: Fact t -> Int -factArity (Fact tag ts) - | length ts == k = k - | otherwise = error $ "factArity: tag of arity " ++ show k ++ - " applied to " ++ show (length ts) ++ " terms" - where - k = factTagArity tag - --- | The multiplicity of a 'Fact'. -factMultiplicity :: Fact t -> Multiplicity -factMultiplicity = factTagMultiplicity . factTag - - ------------------------------------------------------------------------------- --- NFact ------------------------------------------------------------------------------- - --- | Facts with literals containing names and arbitrary variables. -type NFact v = Fact (NTerm v) - - ------------------------------------------------------------------------------- --- LFact ------------------------------------------------------------------------------- - --- | Facts with literals arbitrary constants and logical variables. -type LFact c = Fact (LTerm c) - --- | Facts used for proving; i.e. variables fixed to logical variables --- and constant fixed to names. -type LNFact = Fact LNTerm - --- | Unify a list of @LFact@ equalities. -unifyLNFactEqs :: [Equal LNFact] -> WithMaude [LNSubstVFresh] -unifyLNFactEqs eqs - | all (evalEqual . fmap factTag) 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@. -matchFact :: Fact t -- ^ Term - -> Fact t -- ^ Pattern - -> Match t -matchFact t p = - matchOnlyIf (factTag t == factTag p && - length (factTerms t) == length (factTerms p)) - <> mconcat (zipWith matchWith (factTerms t) (factTerms p)) - ------------------------------------------------------------------------------- --- Pretty Printing ------------------------------------------------------------------------------- - --- | The name of a fact tag, e.g., @factTagName KUFact = "KU"@. -factTagName :: FactTag -> String -factTagName tag = case tag of - KUFact -> "KU" - KDFact -> "KD" - DedFact -> "Ded" - InFact -> "In" - OutFact -> "Out" - FreshFact -> "Fr" - (ProtoFact _ n _) -> n - --- | Show a fact tag as a 'String'. This is the 'factTagName' prefixed with --- the multiplicity. -showFactTag :: FactTag -> String -showFactTag tag = - (++ factTagName tag) $ case factTagMultiplicity tag of - Linear -> "" - Persistent -> "!" - --- | Show a fact tag together with its aritiy. -showFactTagArity :: FactTag -> String -showFactTagArity tag = showFactTag tag ++ "/" ++ show (factTagArity tag) - --- | Pretty print a fact. -prettyFact :: Document d => (t -> d) -> Fact t -> d -prettyFact ppTerm (Fact tag ts) - | factTagArity tag /= length ts = ppFact ("MALFORMED-" ++ show tag) ts - | otherwise = ppFact (showFactTag tag) ts - where - ppFact n = nestShort' (n ++ "(") ")" . fsep . punctuate comma . map ppTerm - --- | Pretty print a 'NFact'. -prettyNFact :: Document d => LNFact -> d -prettyNFact = prettyFact prettyNTerm - --- | Pretty print a 'LFact'. -prettyLNFact :: Document d => LNFact -> d -prettyLNFact fa = prettyFact prettyNTerm fa - --- derived instances --------------------- - -$( derive makeBinary ''Multiplicity) -$( derive makeBinary ''FactTag) -$( derive makeBinary ''Fact) - -$( derive makeNFData ''Multiplicity) -$( derive makeNFData ''FactTag) -$( derive makeNFData ''Fact) diff --git a/src/Theory/Model/Formula.hs b/src/Theory/Model/Formula.hs deleted file mode 100644 --- a/src/Theory/Model/Formula.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Types and operations for handling sorted first-order logic -module Theory.Model.Formula ( - - -- * Formulas - Connective(..) - , Quantifier(..) - , Formula(..) - , LNFormula - , LFormula - - , quantify - , openFormula - , openFormulaPrefix --- , unquantify - - -- ** More convenient constructors - , lfalse - , ltrue - , (.&&.) - , (.||.) - , (.==>.) - , (.<=>.) - , exists - , forall - - -- ** General Transformations - , mapAtoms - , foldFormula - - -- ** Pretty-Printing - , prettyLNFormula - - ) where - -import Prelude hiding (negate) - -import Data.Binary -import Data.DeriveTH -import Data.Foldable (Foldable, foldMap) -import Data.Generics -import Data.Monoid hiding (All) -import Data.Traversable - -import Control.Basics -import Control.DeepSeq -import Control.Monad.Fresh -import qualified Control.Monad.Trans.PreciseFresh as Precise - -import Theory.Model.Atom - -import Text.PrettyPrint.Highlight - -import Term.LTerm -import Term.Substitution - ------------------------------------------------------------------------------- --- Types ------------------------------------------------------------------------------- - --- | Logical connectives. -data Connective = And | Or | Imp | Iff - deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable ) - --- | Quantifiers. -data Quantifier = All | Ex - deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable ) - - --- | First-order formulas in locally nameless representation with hints for the --- names/sorts of quantified variables. -data Formula s c v = Ato (Atom (VTerm c (BVar v))) - | TF !Bool - | Not (Formula s c v) - | Conn !Connective (Formula s c v) (Formula s c v) - | Qua !Quantifier s (Formula s c v) - --- Folding ----------- - --- | Fold a formula. -{-# INLINE foldFormula #-} -foldFormula :: (Atom (VTerm c (BVar v)) -> b) -> (Bool -> b) - -> (b -> b) -> (Connective -> b -> b -> b) - -> (Quantifier -> s -> b -> b) - -> Formula s c v - -> b -foldFormula fAto fTF fNot fConn fQua = - go - where - go (Ato a) = fAto a - go (TF b) = fTF b - go (Not p) = fNot (go p) - go (Conn c p q) = fConn c (go p) (go q) - go (Qua qua x p) = fQua qua x (go p) - --- | Fold a formula. -{-# INLINE foldFormulaScope #-} -foldFormulaScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b) - -> (b -> b) -> (Connective -> b -> b -> b) - -> (Quantifier -> s -> b -> b) - -> Formula s c v - -> b -foldFormulaScope fAto fTF fNot fConn fQua = - go 0 - where - go !i (Ato a) = fAto i a - go _ (TF b) = fTF b - go !i (Not p) = fNot (go i p) - go !i (Conn c p q) = fConn c (go i p) (go i q) - go !i (Qua qua x p) = fQua qua x (go (succ i) p) - - --- 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 . traverseAtom (traverseTerm (traverseLit (traverseBVar f)))) - (pure . TF) (liftA Not) - (liftA2 . Conn) ((liftA .) . Qua) --} - --- Abbreviations ----------------- - -infixl 3 .&&. -infixl 2 .||. -infixr 1 .==>. -infix 1 .<=>. - --- | Logically true. -ltrue :: Formula a s v -ltrue = TF True - --- | Logically false. -lfalse :: Formula a s v -lfalse = TF False - -(.&&.), (.||.), (.==>.), (.<=>.) :: Formula a s v -> Formula a s v -> Formula a s v -(.&&.) = Conn And -(.||.) = Conn Or -(.==>.) = Conn Imp -(.<=>.) = Conn Iff - ------------------------------------------------------------------------------- --- Dealing with bound variables ------------------------------------------------------------------------------- - --- | @LFormula@ are FOL formulas with sorts abused to denote both a hint for --- the name of the bound variable, as well as the variable's actual sort. -type LFormula c = Formula (String, LSort) c LVar - -type LNFormula = Formula (String, LSort) Name LVar - --- | Change the representation of atoms. -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, 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 (mapLits (subst x i)) a) fm) - ) - where - subst x i (Var (Bound i')) | i == i' = Var $ Free x - subst _ _ l = l - -openFormula _ = Nothing - -mapLits :: (Ord a, Ord b) => (a -> b) -> Term a -> Term b -mapLits f t = case viewTerm t of - Lit l -> lit . f $ l - 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, Ord c) - => LFormula c -> m ([LVar], Quantifier, LFormula c) -openFormulaPrefix f0 = case openFormula f0 of - Nothing -> error $ "openFormulaPrefix: no outermost quantifier" - Just (q, open) -> do - (x, f) <- open - go q [x] f - where - go q xs f = case openFormula f of - Just (q', open') | q' == q -> do (x', f') <- open' - go q (x' : xs) f' - -- no further quantifier of the same kind => return result - _ -> return (reverse xs, q, f) - - --- Instances ------------- - -deriving instance Eq LNFormula -deriving instance Show LNFormula -deriving instance Ord LNFormula - -instance HasFrees LNFormula where - foldFrees f = foldMap (foldFrees f) - mapFrees f = traverseFormula (mapFrees f) - -instance Apply LNFormula where - apply subst = mapAtoms (const $ apply subst) - ------------------------------------------------------------------------------- --- Formulas modulo E and modulo AC ------------------------------------------------------------------------------- - --- | Introduce a bound variable for a free variable. -quantify :: (Ord c, Ord v, Eq v) => v -> Formula s c v -> Formula s c v -quantify x = - 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 :: (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 :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v -exists hint x = Qua Ex hint . quantify x - ------------------------------------------------------------------------------- --- Pretty printing ------------------------------------------------------------------------------- - --- | Pretty print a formula. -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. -prettyLFormula ppAtom = - pp - where - extractFree (Free v) = v - extractFree (Bound i) = error $ "prettyFormula: illegal bound variable '" ++ show i ++ "'" - - pp (Ato a) = return $ ppAtom (fmap (mapLits (fmap extractFree)) a) - pp (TF True) = return $ operator_ "⊤" -- "T" - pp (TF False) = return $ operator_ "⊥" -- "F" - - pp (Not p) = do - p' <- pp p - return $ operator_ "¬" <> opParens p' -- text "¬" <> parens (pp a) - -- return $ operator_ "not" <> opParens p' -- text "¬" <> parens (pp a) - - pp (Conn op p q) = do - p' <- pp p - q' <- pp q - return $ sep [opParens p' <-> operator_ (ppOp op), opParens q'] - where - ppOp And = "∧" -- "&" - ppOp Or = "∨" -- "|" - ppOp Imp = "⇒" -- "==>" - ppOp Iff = "⇔" -- "<=>" - - pp fm@(Qua _ _ _) = - scopeFreshness $ do - (vs,qua,fm') <- openFormulaPrefix fm - d' <- pp fm' - return $ sep - [ operator_ (ppQuant qua) <> ppVars vs <> operator_ "." - , nest 1 d'] - where - ppVars = fsep . map (text . show) - - ppQuant All = "∀ " -- "All " - ppQuant Ex = "∃ " -- "Ex " - - --- | Pretty print a logical formula -prettyLNFormula :: HighlightDocument d => LNFormula -> d -prettyLNFormula fm = - Precise.evalFresh (prettyLFormula prettyNAtom fm) (avoidPrecise fm) - - --- Derived instances --------------------- - -$( derive makeBinary ''Connective) -$( derive makeBinary ''Quantifier) -$( derive makeBinary ''Formula) - -$( derive makeNFData ''Connective) -$( derive makeNFData ''Quantifier) -$( derive makeNFData ''Formula) diff --git a/src/Theory/Model/Rule.hs b/src/Theory/Model/Rule.hs deleted file mode 100644 --- a/src/Theory/Model/Rule.hs +++ /dev/null @@ -1,632 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : portable --- --- Rewriting rules representing protocol execution and intruder deduction. Once --- modulo the full Diffie-Hellman equational theory and once modulo AC. -module Theory.Model.Rule ( - -- * General Rules - Rule(..) - , PremIdx(..) - , ConcIdx(..) - - -- ** Accessors - , rInfo - , rPrems - , rConcs - , rActs - , rPrem - , rConc - , lookupPrem - , lookupConc - , enumPrems - , enumConcs - - -- ** Genereal protocol and intruder rules - , RuleInfo(..) - , ruleInfo - - -- * Protocol Rule Information - , ProtoRuleName(..) - , ProtoRuleACInfo(..) - , pracName - , pracVariants - , pracLoopBreakers - , ProtoRuleACInstInfo(..) - , praciName - , praciLoopBreakers - , RuleACConstrs - - -- * Intruder Rule Information - , IntrRuleACInfo(..) - - -- * Concrete Rules - , ProtoRuleE - , ProtoRuleAC - , IntrRuleAC - , RuleAC - , RuleACInst - - -- ** Queries - , HasRuleName(..) - , isIntruderRule - , isDestrRule - , isConstrRule - , isFreshRule - , isIRecvRule - , isISendRule - , isCoerceRule - , nfRule - , isTrivialProtoVariantAC - - -- ** Conversion - , ruleACToIntrRuleAC - , ruleACIntrToRuleAC - - -- ** Construction - , someRuleACInst - - -- ** Unification - , unifyRuleACInstEqs - , unifiableRuleACInsts - - -- * Pretty-Printing - , showRuleCaseName - , prettyProtoRuleName - , prettyRuleName - , prettyProtoRuleE - , prettyProtoRuleAC - , prettyIntrRuleAC - , prettyIntrRuleACInfo - , prettyRuleAC - , prettyLoopBreakers - , prettyRuleACInst - - ) where - -import Prelude hiding (id, (.)) - -import Data.Binary -import qualified Data.ByteString.Char8 as BC -import Data.DeriveTH -import Data.Foldable (foldMap) -import Data.Generics -import Data.List -import Data.Monoid -import Safe - -import Control.Basics -import Control.Category -import Control.DeepSeq -import Control.Monad.Bind -import Control.Monad.Reader - -import Extension.Data.Label hiding (get) -import qualified Extension.Data.Label as L -import Logic.Connectives - -import Term.LTerm -import Term.Rewriting.Norm (nf') -import Term.Unification -import Theory.Model.Fact -import Theory.Text.Pretty - ------------------------------------------------------------------------------- --- General Rule ------------------------------------------------------------------------------- - --- | Rewriting rules with arbitrary additional information and facts with names --- and logical variables. -data Rule i = Rule { - _rInfo :: i - , _rPrems :: [LNFact] - , _rConcs :: [LNFact] - , _rActs :: [LNFact] - } - deriving( Eq, Ord, Show, Data, Typeable ) - -$(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 :: 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 :: 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 :: PremIdx -> (Rule i :-> LNFact) -rPrem i = nthL (getPremIdx i) . rPrems - --- | @rConc i@ is a lens for the @i@-th conclusion of a rule. -rConc :: ConcIdx -> (Rule i :-> LNFact) -rConc i = nthL (getConcIdx i) . rConcs - --- | 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 ------------- - -instance Functor Rule where - fmap f (Rule i ps cs as) = Rule (f i) ps cs as - -instance HasFrees i => HasFrees (Rule i) where - foldFrees f (Rule i ps cs as) = - (foldFrees f i `mappend`) $ - (foldFrees f ps `mappend`) $ - (foldFrees f cs `mappend`) $ - (foldFrees f as) - - mapFrees f (Rule i ps cs as) = - Rule <$> mapFrees f i - <*> mapFrees f ps <*> mapFrees f cs <*> mapFrees f as - -instance Apply i => Apply (Rule i) where - apply subst (Rule i ps cs as) = - Rule (apply subst i) (apply subst ps) (apply subst cs) (apply subst as) - -instance Sized (Rule i) where - size (Rule _ ps cs as) = size ps + size cs + size as - ------------------------------------------------------------------------------- --- Rule information split into intruder rule and protocol rules ------------------------------------------------------------------------------- - --- | Rule information for protocol and intruder rules. -data RuleInfo p i = - ProtoInfo p - | IntrInfo i - deriving( Eq, Ord, Show ) - --- | @ruleInfo proto intr@ maps the protocol information with @proto@ and the --- intruder information with @intr@. -ruleInfo :: (p -> c) -> (i -> c) -> RuleInfo p i -> c -ruleInfo proto _ (ProtoInfo x) = proto x -ruleInfo _ intr (IntrInfo x) = intr x - - --- Instances ------------- - -instance (HasFrees p, HasFrees i) => HasFrees (RuleInfo p i) where - foldFrees f = ruleInfo (foldFrees f) (foldFrees f) - - mapFrees f = ruleInfo (fmap ProtoInfo . mapFrees f) - (fmap IntrInfo . mapFrees f) - -instance (Apply p, Apply i) => Apply (RuleInfo p i) where - apply subst = ruleInfo (ProtoInfo . apply subst) (IntrInfo . apply subst) - - ------------------------------------------------------------------------------- --- Protocol Rule Information ------------------------------------------------------------------------------- - --- | A name of a protocol rule is either one of the special reserved rules or --- some standard rule. -data ProtoRuleName = - FreshRule - | StandRule String -- ^ Some standard protocol rule - deriving( Eq, Ord, Show, Data, Typeable ) - - --- | Information for protocol rules modulo AC. The variants list the possible --- 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) - , _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 ------------- - -instance Apply ProtoRuleName where - apply _ = id - -instance HasFrees ProtoRuleName where - 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 breakers) = - foldFrees f na `mappend` foldFrees f vari - `mappend` foldFrees f breakers - - 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 = - ConstrRule BC.ByteString - | DestrRule BC.ByteString - | CoerceRule - | IRecvRule - | ISendRule - | PubConstrRule - | FreshConstrRule - deriving( Ord, Eq, Show, Data, Typeable ) - --- | An intruder rule modulo AC. -type IntrRuleAC = Rule IntrRuleACInfo - --- | Converts between these two types of rules, if possible. -ruleACToIntrRuleAC :: RuleAC -> Maybe IntrRuleAC -ruleACToIntrRuleAC (Rule (IntrInfo i) ps cs as) = Just (Rule i ps cs as) -ruleACToIntrRuleAC _ = Nothing - --- | Converts between these two types of rules. -ruleACIntrToRuleAC :: IntrRuleAC -> RuleAC -ruleACIntrToRuleAC (Rule ri ps cs as) = Rule (IntrInfo ri) ps cs as - --- Instances ------------- - -instance Apply IntrRuleACInfo where - apply _ = id - -instance HasFrees IntrRuleACInfo where - foldFrees _ = const mempty - mapFrees _ = pure - - ------------------------------------------------------------------------------- --- Concrete rules ------------------------------------------------------------------------------- - --- | A rule modulo E is always a protocol rule. Intruder rules are specified --- abstractly by their operations generating them and are only available once --- their variants are built. -type ProtoRuleE = Rule ProtoRuleName - --- | A protocol rule modulo AC. -type ProtoRuleAC = Rule ProtoRuleACInfo - --- | A rule modulo AC is either a protocol rule or an intruder rule -type RuleAC = Rule (RuleInfo ProtoRuleACInfo IntrRuleACInfo) - --- | 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 ProtoRuleACInstInfo IntrRuleACInfo) - --- Accessing the rule name --------------------------- - --- | Types that have an associated name. -class HasRuleName t where - ruleName :: t -> RuleInfo ProtoRuleName IntrRuleACInfo - -instance HasRuleName ProtoRuleE where - ruleName = ProtoInfo . L.get rInfo - -instance HasRuleName RuleAC where - ruleName = ruleInfo (ProtoInfo . L.get pracName) IntrInfo . L.get rInfo - -instance HasRuleName ProtoRuleAC where - ruleName = ProtoInfo . L.get (pracName . rInfo) - -instance HasRuleName IntrRuleAC where - ruleName = IntrInfo . L.get rInfo - -instance HasRuleName RuleACInst where - ruleName = ruleInfo (ProtoInfo . L.get praciName) IntrInfo . L.get rInfo - - --- Queries ----------- - --- | True iff the rule is a destruction rule. -isDestrRule :: HasRuleName r => r -> Bool -isDestrRule ru = case ruleName ru of - IntrInfo (DestrRule _) -> True - _ -> False - --- | True iff the rule is a construction rule. -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 -isFreshRule = (ProtoInfo FreshRule ==) . ruleName - --- | True iff the rule is the special learn rule. -isIRecvRule :: HasRuleName r => r -> Bool -isIRecvRule = (IntrInfo IRecvRule ==) . ruleName - --- | True iff the rule is the special knows rule. -isISendRule :: HasRuleName r => r -> Bool -isISendRule = (IntrInfo ISendRule ==) . ruleName - --- | True iff the rule is the special coerce rule. -isCoerceRule :: HasRuleName r => r -> Bool -isCoerceRule = (IntrInfo CoerceRule ==) . ruleName - --- | True if the messages in premises and conclusions are in normal form -nfRule :: Rule i -> WithMaude Bool -nfRule (Rule _ ps cs as) = reader $ \hnd -> - all (nfFactList hnd) [ps, cs, as] - where - nfFactList hnd xs = - getAll $ foldMap (foldMap (All . (\t -> nf' t `runReader` hnd))) xs - --- | 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 - --- | 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 be handled. -someRuleACInst :: MonadFresh m - => RuleAC - -> m (RuleACInst, Maybe RuleACConstrs) -someRuleACInst = - fmap extractInsts . rename - where - extractInsts (Rule (ProtoInfo i) ps cs as) = - ( 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 ) - - --- Unification --------------- - --- | Unify a list of @RuleACInst@ equalities. -unifyRuleACInstEqs :: [Equal RuleACInst] -> WithMaude [LNSubstVFresh] -unifyRuleACInstEqs eqs - | all unifiable eqs = unifyLNFactEqs $ concatMap ruleEqs eqs - | otherwise = return [] - where - unifiable (Equal ru1 ru2) = - L.get rInfo ru1 == L.get rInfo ru2 - && length (L.get rPrems ru1) == length (L.get rPrems ru2) - && length (L.get rConcs ru1) == length (L.get rConcs ru2) - - ruleEqs (Equal ru1 ru2) = - zipWith Equal (L.get rPrems ru1) (L.get rPrems ru2) ++ - zipWith Equal (L.get rConcs ru1) (L.get rConcs ru2) - --- | Are these two rule instances unifiable. -unifiableRuleACInsts :: RuleACInst -> RuleACInst -> WithMaude Bool -unifiableRuleACInsts ru1 ru2 = - (not . null) <$> unifyRuleACInstEqs [Equal ru1 ru2] - - ------------------------------------------------------------------------------- --- Fact analysis ------------------------------------------------------------------------------- - --- | Globally unique facts. --- --- A rule instance removes a fact fa if fa is in the rule's premise but not --- in the rule's conclusion. --- --- A fact symbol fa is globally fresh with respect to a dependency graph if --- there are no two rule instances that remove the same fact built from fa. --- --- We are looking for sufficient criterion to prove that a fact symbol is --- globally fresh. --- --- The Fr symbol is globally fresh by construction. --- --- We have to track every creation of a globally fresh fact to a Fr fact. --- --- (And show that the equality of of the created fact implies the equality of --- the corresponding fresh facts. Ignore this for now by assuming that no --- duplication happens.) --- --- (fa(x1), fr(y1)), (fa(x2), fr(y2)) : x2 = x1 ==> y1 == y2 --- --- And ensure that every duplication is non-unifiable. --- --- A Fr fact is described --- --- We track which symbols are not globally fresh. --- --- All persistent facts are not globally fresh. --- --- Adding a rule ru. --- All fact symbols that occur twice in the conclusion --- --- For simplicity: globally fresh fact symbols occur at most once in premise --- and conclusion of a rule. --- --- A fact is removed by a rule if it occurs in the rules premise --- 1. but doesn't occur in the rule's conclusion --- 2. or does occur but non-unifiable. --- --- We want a sufficient criterion to prove that a fact is globally unique. --- --- - ------------------------------------------------------------------------------- --- 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" - StandRule n -> prefixIfReserved n - -prettyRuleName :: (HighlightDocument d, HasRuleName (Rule i)) => Rule i -> d -prettyRuleName = ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName - --- | Pretty print the rule name such that it can be used as a case name -showRuleCaseName :: HasRuleName (Rule i) => Rule i -> String -showRuleCaseName = - render . ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName - -prettyIntrRuleACInfo :: Document d => IntrRuleACInfo -> d -prettyIntrRuleACInfo rn = text $ case rn of - IRecvRule -> "irecv" - ISendRule -> "isend" - CoerceRule -> "coerce" - FreshConstrRule -> "fresh" - PubConstrRule -> "pub" - ConstrRule name -> prefixIfReserved ('c' : BC.unpack name) - DestrRule name -> prefixIfReserved ('d' : BC.unpack name) - -prettyNamedRule :: (HighlightDocument d, HasRuleName (Rule i)) - => d -- ^ Prefix. - -> (i -> d) -- ^ Rule info pretty printing. - -> Rule i -> d -prettyNamedRule prefix ppInfo ru = - prefix <-> prettyRuleName ru <> colon $-$ - nest 2 (sep [ nest 1 $ ppFactsList rPrems - , if null (L.get rActs ru) - then operator_ "-->" - else fsep [operator_ "--[", ppFacts rActs, operator_ "]->"] - , nest 1 $ ppFactsList rConcs]) $-$ - nest 2 (ppInfo $ L.get rInfo ru) - where - ppList pp = fsep . punctuate comma . map pp - ppFacts proj = ppList prettyLNFact $ L.get proj ru - ppFactsList proj = fsep [operator_ "[", ppFacts proj, operator_ "]"] - -prettyProtoRuleACInfo :: HighlightDocument d => ProtoRuleACInfo -> d -prettyProtoRuleACInfo 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) - -prettyRuleAC :: HighlightDocument d => RuleAC -> d -prettyRuleAC = - prettyNamedRule (kwRuleModulo "AC") - (ruleInfo prettyProtoRuleACInfo (const emptyDoc)) - -prettyIntrRuleAC :: HighlightDocument d => IntrRuleAC -> d -prettyIntrRuleAC = prettyNamedRule (kwRuleModulo "AC") (const emptyDoc) - -prettyProtoRuleAC :: HighlightDocument d => ProtoRuleAC -> d -prettyProtoRuleAC = prettyNamedRule (kwRuleModulo "AC") prettyProtoRuleACInfo - -prettyRuleACInst :: HighlightDocument d => RuleACInst -> d -prettyRuleACInst = prettyNamedRule (kwInstanceModulo "AC") (const emptyDoc) - --- derived instances --------------------- - -$( 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/Model/Signature.hs b/src/Theory/Model/Signature.hs deleted file mode 100644 --- a/src/Theory/Model/Signature.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : portable --- --- Signatures for the terms and multiset rewriting rules used to model and --- reason about a security protocol. --- modulo the full Diffie-Hellman equational theory and once modulo AC. -module Theory.Model.Signature ( - - -- * Signature type - Signature(..) - - -- ** Pure signatures - , SignaturePure - , emptySignaturePure - , sigpMaudeSig - - -- ** Using Maude to handle operations relative to a 'Signature' - , SignatureWithMaude - , toSignatureWithMaude - , toSignaturePure - , sigmMaudeHandle - - -- ** Pretty-printing - , prettySignaturePure - , prettySignatureWithMaude - - ) where - -import Data.Binary -import qualified Data.Label as L - -import Control.Applicative -import Control.DeepSeq - -import System.IO.Unsafe (unsafePerformIO) - -import Term.Maude.Process (MaudeHandle, mhFilePath, mhMaudeSig, startMaude) -import Term.Maude.Signature (MaudeSig, minimalMaudeSig, prettyMaudeSig) -import Theory.Text.Pretty - - --- | A theory signature. -data Signature a = Signature - { -- The signature of the message algebra - _sigMaudeInfo :: a - } - -$(L.mkLabels [''Signature]) - - ------------------------------------------------------------------------------- --- Pure Signatures ------------------------------------------------------------------------------- - --- | A 'Signature' without an associated Maude process. -type SignaturePure = Signature MaudeSig - --- | Access the maude signature. -sigpMaudeSig:: SignaturePure L.:-> MaudeSig -sigpMaudeSig = sigMaudeInfo - --- | The empty pure signature. -emptySignaturePure :: SignaturePure -emptySignaturePure = Signature minimalMaudeSig - --- Instances ------------- - -deriving instance Eq SignaturePure -deriving instance Ord SignaturePure -deriving instance Show SignaturePure - -instance Binary SignaturePure where - put sig = put (L.get sigMaudeInfo sig) - get = Signature <$> get - -instance NFData SignaturePure where - rnf (Signature y) = rnf y - ------------------------------------------------------------------------------- --- Signatures with an attached Maude process ------------------------------------------------------------------------------- - --- | A 'Signature' with an associated, running Maude process. -type SignatureWithMaude = Signature MaudeHandle - --- | Access the maude handle in a signature. -sigmMaudeHandle :: SignatureWithMaude L.:-> MaudeHandle -sigmMaudeHandle = sigMaudeInfo - --- | Ensure that maude is running and configured with the current signature. -toSignatureWithMaude :: FilePath -- ^ Path to Maude executable. - -> SignaturePure - -> IO (SignatureWithMaude) -toSignatureWithMaude maudePath sig = do - hnd <- startMaude maudePath (L.get sigMaudeInfo sig) - return $ sig { _sigMaudeInfo = hnd } - - --- | The pure signature of a 'SignatureWithMaude'. -toSignaturePure :: SignatureWithMaude -> SignaturePure -toSignaturePure sig = sig { _sigMaudeInfo = mhMaudeSig $ L.get sigMaudeInfo sig } - -{- TODO: There should be a finalizer in place such that as soon as the - MaudeHandle is garbage collected, the appropriate command is sent to Maude - - The code below is a crutch and leads to unnecessary complication. - - --- | Stop the maude process. This operation is unsafe, as there still might be --- thunks that rely on the MaudeHandle to refer to a running Maude process. -unsafeStopMaude :: SignatureWithMaude -> IO (SignaturePure) -unsafeStopMaude = error "unsafeStopMaude: implement" - --- | Run an IO action with maude running and configured with a specific --- signature. As there must not be any part of the return value that depends --- on unevaluated calls to the Maude process provided to the inner IO action. -unsafeWithMaude :: FilePath -- ^ Path to Maude executable - -> SignaturePure -- ^ Signature to use - -> (SignatureWithMaude -> IO a) -> IO a -unsafeWithMaude maudePath sig = - bracket (startMaude maudePath sig) unsafeStopMaude - --} - --- Instances ------------- - -instance Eq SignatureWithMaude where - x == y = toSignaturePure x == toSignaturePure y - -instance Ord SignatureWithMaude where - compare x y = compare (toSignaturePure x) (toSignaturePure y) - -instance Show SignatureWithMaude where - show = show . toSignaturePure - -instance Binary SignatureWithMaude where - put sig@(Signature maude) = do - put (mhFilePath maude) - put (toSignaturePure sig) - -- FIXME: reload the right signature - get = unsafePerformIO <$> (toSignatureWithMaude <$> get <*> get) - -instance NFData SignatureWithMaude where - rnf (Signature _maude) = () - ------------------------------------------------------------------------------- --- Pretty-printing ------------------------------------------------------------------------------- - --- | Pretty-print a signature with maude. -prettySignaturePure :: HighlightDocument d => SignaturePure -> d -prettySignaturePure sig = - prettyMaudeSig $ L.get sigpMaudeSig sig - --- | Pretty-print a pure signature. -prettySignatureWithMaude :: HighlightDocument d => SignatureWithMaude -> d -prettySignatureWithMaude sig = - prettyMaudeSig $ mhMaudeSig $ L.get sigmMaudeHandle sig - diff --git a/src/Theory/Proof.hs b/src/Theory/Proof.hs deleted file mode 100644 --- a/src/Theory/Proof.hs +++ /dev/null @@ -1,654 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} --- | --- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Types to represent proofs. -module Theory.Proof ( - -- * Utilities - LTree(..) - , mergeMapsWith - - -- * Types - , ProofStep(..) - , Proof - - -- ** Paths inside proofs - , ProofPath - , atPath - , insertPaths - - -- ** Folding/modifying proofs - , mapProofInfo - , foldProof - , annotateProof - , ProofStatus(..) - , proofStepStatus - - -- ** Unfinished proofs - , sorry - , unproven - - -- ** Incremental proof construction - , IncrementalProof - , Prover - , runProver - , mapProverProof - - , orelse - , tryProver - , sorryProver - , oneStepProver - , focus - , checkAndExtendProver - , replaceSorryProver - , contradictionProver - - -- ** Explicit representation of a fully automatic prover - , SolutionExtractor(..) - , AutoProver(..) - , runAutoProver - - -- ** Pretty Printing - , prettyProof - , prettyProofWith - - , showProofStatus - - -- ** Parallel Strategy for exploring a proof - , parLTreeDFS - - -- ** Small-step interface to the constraint solver - , module Theory.Constraint.Solver - -) where - -import Data.Binary -import Data.DeriveTH -import Data.Foldable (Foldable, foldMap) -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid -import Data.Traversable - -import Debug.Trace - -import Control.Basics -import Control.DeepSeq -import qualified Control.Monad.State as S -import Control.Parallel.Strategies - -import Theory.Constraint.Solver -import Theory.Model -import Theory.Text.Pretty - - ------------------------------------------------------------------------------- --- Utility: Trees with uniquely labelled edges. ------------------------------------------------------------------------------- - --- | Trees with uniquely labelled edges. -data LTree l a = LNode - { root :: a - , children :: M.Map l (LTree l a) - } - deriving( Eq, Ord, Show ) - -instance Functor (LTree l) where - fmap f (LNode r cs) = LNode (f r) (M.map (fmap f) cs) - -instance Foldable (LTree l) where - foldMap f (LNode x cs) = f x `mappend` foldMap (foldMap f) cs - -instance Traversable (LTree l) where - traverse f (LNode x cs) = LNode <$> f x <*> traverse (traverse f) cs - --- | A parallel evaluation strategy well-suited for DFS traversal: As soon as --- a node is forced it sparks off the computation of the number of case-maps --- of all its children. This way most of the data is already evaulated, when --- the actual DFS traversal visits it. --- --- NOT used for now. It sometimes required too much memory. -parLTreeDFS :: Strategy (LTree l a) -parLTreeDFS (LNode x0 cs0) = do - cs0' <- (`parTraversable` cs0) $ \(LNode x cs) -> LNode x <$> rseq cs - return $ LNode x0 (M.map (runEval . parLTreeDFS) cs0') - ------------------------------------------------------------------------------- --- Utility: Merging maps ------------------------------------------------------------------------------- - --- | /O(n+m)/. A generalized union operator for maps with differing types. -mergeMapsWith :: Ord k - => (a -> c) -> (b -> c) -> (a -> b -> c) - -> M.Map k a -> M.Map k b -> M.Map k c -mergeMapsWith leftOnly rightOnly combine l r = - M.map extract $ M.unionWith combine' l' r' - where - l' = M.map (Left . Left) l - r' = M.map (Left . Right) r - - combine' (Left (Left a)) (Left (Right b)) = Right $ combine a b - combine' _ _ = error "mergeMapsWith: impossible" - - extract (Left (Left a)) = leftOnly a - extract (Left (Right b)) = rightOnly b - extract (Right c) = c - - ------------------------------------------------------------------------------- --- Proof Steps ------------------------------------------------------------------------------- - --- | A proof steps is a proof method together with additional context-dependent --- information. -data ProofStep a = ProofStep - { psMethod :: ProofMethod - , psInfo :: a - } - deriving( Eq, Ord, Show ) - -instance Functor ProofStep where - fmap f (ProofStep m i) = ProofStep m (f i) - -instance Foldable ProofStep where - foldMap f = f . psInfo - -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 ------------------------------------------------------------------------------- - --- | A path to a subproof. -type ProofPath = [CaseName] - --- | A proof is a tree of proof steps whose edges are labelled with case names. -type Proof a = LTree CaseName (ProofStep a) - --- Unfinished proofs --------------------- - --- | A proof using the 'sorry' proof method. -sorry :: Maybe String -> a -> Proof a -sorry reason ann = LNode (ProofStep (Sorry reason) ann) M.empty - --- | A proof denoting an unproven part of the proof. -unproven :: a -> Proof a -unproven = sorry Nothing - - --- Paths in proofs ------------------- - --- | @prf `atPath` path@ returns the subproof at the @path@ in @prf@. -atPath :: Proof a -> ProofPath -> Maybe (Proof a) -atPath = foldM (flip M.lookup . children) - --- | @modifyAtPath f path prf@ applies @f@ to the subproof at @path@, --- if there is one. -modifyAtPath :: (Proof a -> Maybe (Proof a)) -> ProofPath - -> Proof a -> Maybe (Proof a) -modifyAtPath f = - go - where - go [] prf = f prf - go (l:ls) prf = do - let cs = children prf - prf' <- go ls =<< M.lookup l cs - return (prf { children = M.insert l prf' cs }) - --- | @insertPaths prf@ inserts the path to every proof node. -insertPaths :: Proof a -> Proof (a, ProofPath) -insertPaths = - insertPath [] - where - insertPath path (LNode ps cs) = - LNode (fmap (,reverse path) ps) - (M.mapWithKey (\n prf -> insertPath (n:path) prf) cs) - - --- Utilities for dealing with proofs ------------------------------------- - - --- | Apply a function to the information of every proof step. -mapProofInfo :: (a -> b) -> Proof a -> Proof b -mapProofInfo = fmap . fmap - --- | @boundProofDepth bound prf@ bounds the depth of the proof @prf@ using --- 'Sorry' steps to replace the cut sub-proofs. -boundProofDepth :: Int -> Proof a -> Proof a -boundProofDepth bound = - go bound - where - go n (LNode ps@(ProofStep _ info) cs) - | 0 < n = LNode ps $ M.map (go (pred n)) cs - | otherwise = sorry (Just $ "bound " ++ show bound ++ " hit") info - --- | Fold a proof. -foldProof :: Monoid m => (ProofStep a -> m) -> Proof a -> m -foldProof f = - go - 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 ----------------- - --- | The status of a 'Proof'. -data ProofStatus = - UndeterminedProof -- ^ All steps are unannotated - | CompleteProof -- ^ The proof is complete: no annotated sorry, - -- no annotated solved step - | IncompleteProof -- ^ There is a annotated sorry, - -- but no annotatd solved step. - | TraceFound -- ^ There is an annotated solved step - -instance Monoid ProofStatus where - mempty = CompleteProof - - mappend TraceFound _ = TraceFound - mappend _ TraceFound = TraceFound - mappend IncompleteProof _ = IncompleteProof - mappend _ IncompleteProof = IncompleteProof - mappend _ CompleteProof = CompleteProof - mappend CompleteProof _ = CompleteProof - mappend UndeterminedProof UndeterminedProof = UndeterminedProof - --- | The status of a 'ProofStep'. -proofStepStatus :: ProofStep (Maybe a) -> ProofStatus -proofStepStatus (ProofStep _ Nothing ) = UndeterminedProof -proofStepStatus (ProofStep Solved (Just _)) = TraceFound -proofStepStatus (ProofStep (Sorry _) (Just _)) = IncompleteProof -proofStepStatus (ProofStep _ (Just _)) = CompleteProof - - -{- TODO: Test and probably improve - --- | @proveSystem rules se@ tries to construct a proof that @se@ is valid. --- This proof may contain 'Sorry' steps, if the prover is stuck. It can also be --- of infinite depth, if the proof strategy loops. -proveSystemIterDeep :: ProofContext -> System -> Proof System -proveSystemIterDeep rules se0 = - fromJust $ asum $ map (prove se0 . round) $ iterate (*1.5) (3::Double) - where - prove :: System -> Int -> Maybe (Proof System) - prove se bound - | bound < 0 = Nothing - | otherwise = - case next of - [] -> pure $ sorry "prover stuck => possible attack found" se - xs -> asum $ map mkProof xs - where - next = do m <- possibleProofMethods se - (m,) <$> maybe mzero return (execProofMethod rules m se) - mkProof (method, cases) = - LNode (ProofStep method se) <$> traverse (`prove` (bound - 1)) cases --} - --- | @checkProof rules se prf@ replays the proof @prf@ against the start --- sequent @se@. A failure to apply a proof method is denoted by a resulting --- proof step without an annotated sequent. An unhandled case is denoted using --- the 'Sorry' proof method. -checkProof :: ProofContext - -> (Int -> System -> Proof (Maybe System)) -- prover for new cases in depth - -> Int -- ^ Original depth - -> System - -> Proof a - -> Proof (Maybe a, Maybe System) -checkProof ctxt prover d sys prf@(LNode (ProofStep method info) cs) = - case (method, execProofMethod ctxt method sys) of - (Sorry reason, _ ) -> sorryNode reason cs - (_ , Just cases) -> node method $ checkChildren cases - (_ , Nothing ) -> - sorryNode (Just "invalid proof step encountered") - (M.singleton "" prf) - where - node m = LNode (ProofStep m (Just info, Just sys)) - sorryNode reason cases = node (Sorry reason) (M.map noSystemPrf cases) - noSystemPrf = mapProofInfo (\i -> (Just i, Nothing)) - - checkChildren cases = mergeMapsWith - unhandledCase noSystemPrf (checkProof ctxt prover (d + 1)) cases cs - where - unhandledCase = mapProofInfo ((,) Nothing) . prover d - --- | Annotate a proof with the constraint systems of all intermediate steps --- under the assumption that all proof steps are valid. If some proof steps --- might be invalid, then you must use 'checkProof', which handles them --- gracefully. -annotateWithSystems :: ProofContext -> System -> Proof () -> Proof System -annotateWithSystems ctxt = - go - where - -- Here we are careful to construct the result such that an inspection of - -- the proof does not force the recomputed constraint systems. - go sysOrig (LNode (ProofStep method _) csOrig) = - LNode (ProofStep method sysOrig) $ M.fromList $ do - (name, prf) <- M.toList csOrig - let sysAnn = extract ("case '" ++ name ++ "' non-existent") $ - M.lookup name csAnn - return (name, go sysAnn prf) - where - extract msg = fromMaybe (error $ "annotateWithSystems: " ++ msg) - csAnn = extract "proof method execution failed" $ - execProofMethod ctxt method sysOrig - - ------------------------------------------------------------------------------- --- Provers: the interface to the outside world. ------------------------------------------------------------------------------- - --- | Incremental proofs are used to represent intermediate results of proof --- checking/construction. -type IncrementalProof = Proof (Maybe System) - --- | Provers whose sequencing is handled via the 'Monoid' instance. --- --- > p1 `mappend` p2 --- --- Is a prover that first runs p1 and then p2 on the resulting proof. -newtype Prover = Prover - { runProver - :: ProofContext -- proof rules to use - -> Int -- proof depth - -> System -- original sequent to start with - -> IncrementalProof -- original proof - -> Maybe IncrementalProof -- resulting proof - } - -instance Monoid Prover where - mempty = Prover $ \_ _ _ -> Just - p1 `mappend` p2 = Prover $ \ctxt d se -> - runProver p1 ctxt d se >=> runProver p2 ctxt d se - --- | Map the proof generated by the prover. -mapProverProof :: (IncrementalProof -> IncrementalProof) -> Prover -> Prover -mapProverProof f p = Prover $ \ ctxt d se prf -> f <$> runProver p ctxt d se prf - --- | Prover that always fails. -failProver :: Prover -failProver = Prover (\ _ _ _ _ -> Nothing) - --- | Resorts to the second prover, if the first one is not successful. -orelse :: Prover -> Prover -> Prover -orelse p1 p2 = Prover $ \ctxt d se prf -> - runProver p1 ctxt d se prf `mplus` runProver p2 ctxt d se prf - --- | Try to apply a prover. If it fails, just return the original proof. -tryProver :: Prover -> Prover -tryProver = (`orelse` mempty) - --- | Try to execute one proof step using the given proof method. -oneStepProver :: ProofMethod -> Prover -oneStepProver method = Prover $ \ctxt _ se _ -> do - cases <- execProofMethod ctxt method se - return $ LNode (ProofStep method (Just se)) (M.map (unproven . Just) cases) - --- | Replace the current proof with a sorry step and the given reason. -sorryProver :: Maybe String -> Prover -sorryProver reason = Prover $ \_ _ se _ -> return $ sorry reason (Just se) - --- | Apply a prover only to a sub-proof, fails if the subproof doesn't exist. -focus :: ProofPath -> Prover -> Prover -focus [] prover = prover -focus path prover = - Prover $ \ctxt d _ prf -> - modifyAtPath (prover' ctxt (d + length path)) path prf - where - prover' ctxt d prf = do - se <- psInfo (root prf) - runProver prover ctxt d se prf - --- | Check the proof and handle new cases using the given prover. -checkAndExtendProver :: Prover -> Prover -checkAndExtendProver prover0 = Prover $ \ctxt d se prf -> - return $ mapProofInfo snd $ checkProof ctxt (prover ctxt) d se prf - where - unhandledCase = sorry (Just "unhandled case") Nothing - prover ctxt d se = - fromMaybe unhandledCase $ runProver prover0 ctxt d se unhandledCase - --- | Replace all annotated sorry steps using the given prover. -replaceSorryProver :: Prover -> Prover -replaceSorryProver prover0 = Prover prover - where - prover ctxt d _ = return . replace - where - replace prf@(LNode (ProofStep (Sorry _) (Just se)) _) = - fromMaybe prf $ runProver prover0 ctxt d se prf - replace (LNode ps cases) = - LNode ps $ M.map replace cases - - --- | Use the first prover that works. -firstProver :: [Prover] -> Prover -firstProver = foldr orelse failProver - --- | Prover that does one contradiction step. -contradictionProver :: Prover -contradictionProver = Prover $ \ctxt d sys prf -> - runProver - (firstProver $ map oneStepProver $ - (Contradiction . Just <$> contradictions ctxt sys)) - ctxt d sys prf - ------------------------------------------------------------------------------- --- Automatic Prover's ------------------------------------------------------------------------------- - -data SolutionExtractor = CutDFS | CutBFS | CutNothing - deriving( Eq, Ord, Show, Read ) - -data AutoProver = AutoProver - { apHeuristic :: Heuristic - , apBound :: Maybe Int - , apCut :: SolutionExtractor - } - -runAutoProver :: AutoProver -> Prover -runAutoProver (AutoProver heuristic bound cut) = - mapProverProof cutSolved $ maybe id boundProver bound autoProver - where - cutSolved = case cut of - CutDFS -> cutOnSolvedDFS - CutBFS -> cutOnSolvedBFS - CutNothing -> id - - -- | The standard automatic prover that ignores the existing proof and - -- tries to find one by itself. - autoProver :: Prover - autoProver = Prover $ \ctxt depth sys _ -> - return $ fmap (fmap Just) - $ annotateWithSystems ctxt sys - $ proveSystemDFS heuristic ctxt depth sys - - -- | Bound the depth of proofs generated by the given prover. - boundProver :: Int -> Prover -> Prover - boundProver b p = Prover $ \ctxt d se prf -> - boundProofDepth b <$> runProver p ctxt d se prf - - --- | The result of one pass of iterative deepening. -data IterDeepRes = NoSolution | MaybeNoSolution | Solution ProofPath - -instance Monoid IterDeepRes where - mempty = NoSolution - - x@(Solution _) `mappend` _ = x - _ `mappend` y@(Solution _) = y - MaybeNoSolution `mappend` _ = MaybeNoSolution - _ `mappend` MaybeNoSolution = MaybeNoSolution - NoSolution `mappend` NoSolution = NoSolution - --- | @cutOnSolvedDFS prf@ removes all other cases if an attack is found. The --- attack search is performed using a parallel DFS traversal with iterative --- deepening. --- --- FIXME: Note that this function may use a lot of space, as it holds onto the --- whole proof tree. -cutOnSolvedDFS :: Proof (Maybe a) -> Proof (Maybe a) -cutOnSolvedDFS prf0 = - go (4 :: Integer) $ insertPaths prf0 - where - go dMax prf = case findSolved 0 prf of - NoSolution -> prf0 - MaybeNoSolution -> go (2 * dMax) prf - Solution path -> extractSolved path prf0 - where - findSolved d node - | d >= dMax = MaybeNoSolution - | otherwise = case node of - -- do not search in nodes that are not annotated - LNode (ProofStep _ (Nothing, _ )) _ -> NoSolution - LNode (ProofStep Solved (Just _ , path)) _ -> Solution path - LNode (ProofStep _ (Just _ , _ )) cs -> - foldMap (findSolved (succ d)) - (cs `using` parTraversable nfProofMethod) - - nfProofMethod node = do - void $ rseq (psMethod $ root node) - void $ rseq (psInfo $ root node) - void $ rseq (children node) - return node - - extractSolved [] p = p - extractSolved (label:ps) (LNode pstep m) = case M.lookup label m of - Just subprf -> - LNode pstep (M.fromList [(label, extractSolved ps subprf)]) - Nothing -> - error "Theory.Constraint.cutOnSolvedDFS: impossible, extractSolved failed, invalid path" - --- | Search for attacks in a BFS manner. -cutOnSolvedBFS :: Proof (Maybe a) -> Proof (Maybe a) -cutOnSolvedBFS = - go (1::Int) - where - go l prf = - -- FIXME: See if that poor man's logging could be done better. - trace ("searching for attacks at depth: " ++ show l) $ - case S.runState (checkLevel l prf) CompleteProof of - (_, UndeterminedProof) -> error "cutOnSolvedBFS: impossible" - (_, CompleteProof) -> prf - (_, IncompleteProof) -> go (l+1) prf - (prf', TraceFound) -> - trace ("attack found at depth: " ++ show l) prf' - - checkLevel 0 (LNode step@(ProofStep Solved (Just _)) _) = - 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 - TraceFound -> return $ "ignored (attack exists)" - _ -> S.put IncompleteProof >> return "bound reached" - return $ LNode (ProofStep (Sorry (Just msg)) x) M.empty - checkLevel l prf@(LNode step cs) - | isNothing (psInfo step) = return prf - | otherwise = LNode step <$> traverse (checkLevel (l-1)) cs - - --- | @proveSystemDFS rules se@ explores all solutions of the initial --- constraint system using a depth-first-search strategy to resolve the --- non-determinism wrt. what goal to solve next. This proof can be of --- infinite depth, if the proof strategy loops. --- --- Use 'annotateWithSystems' to annotate the proof tree with the constraint --- systems. -proveSystemDFS :: Heuristic -> ProofContext -> Int -> System -> Proof () -proveSystemDFS heuristic ctxt d0 sys0 = - prove d0 sys0 - where - prove !depth sys = - case rankProofMethods (useHeuristic heuristic depth) ctxt sys of - [] -> node Solved M.empty - (method, (cases, _expl)):_ -> node method cases - where - node method cases = - LNode (ProofStep method ()) (M.map (prove (succ depth)) cases) - - ------------------------------------------------------------------------------- --- Pretty printing ------------------------------------------------------------------------------- - - -prettyProof :: HighlightDocument d => Proof a -> d -prettyProof = prettyProofWith (prettyProofMethod . psMethod) (const id) - -prettyProofWith :: HighlightDocument d - => (ProofStep a -> d) -- ^ Make proof step pretty - -> (ProofStep a -> d -> d) -- ^ Make whole case pretty - -> Proof a -- ^ The proof to prettify - -> d -prettyProofWith prettyStep prettyCase = - ppPrf - where - ppPrf (LNode ps cs) = ppCases ps (M.toList cs) - - ppCases ps@(ProofStep Solved _) [] = prettyStep ps - ppCases ps [] = prettyCase ps (kwBy <> text " ") - <> prettyStep ps - ppCases ps [("", prf)] = prettyStep ps $-$ ppPrf prf - ppCases ps cases = - prettyStep ps $-$ - (vcat $ intersperse (prettyCase ps kwNext) $ map ppCase cases) $-$ - prettyCase ps kwQED - - ppCase (name, prf) = nest 2 $ - (prettyCase (root prf) $ kwCase <-> text name) $-$ - ppPrf prf - --- | Convert a proof status to a redable string. -showProofStatus :: SystemTraceQuantifier -> 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" -showProofStatus _ UndeterminedProof = "analysis undetermined" - - --- Derived instances --------------------- - -$( derive makeBinary ''ProofStep) -$( derive makeBinary ''ProofStatus) -$( derive makeBinary ''SolutionExtractor) -$( derive makeBinary ''AutoProver) - -$( derive makeNFData ''ProofStep) -$( derive makeNFData ''ProofStatus) -$( derive makeNFData ''SolutionExtractor) -$( derive makeNFData ''AutoProver) - -instance (Ord l, NFData l, NFData a) => NFData (LTree l a) where - rnf (LNode r m) = rnf r `seq` rnf m - -instance (Ord l, Binary l, Binary a) => Binary (LTree l a) where - put (LNode r m) = put r >> put m - get = LNode <$> get <*> get diff --git a/src/Theory/Text/Parser.hs b/src/Theory/Text/Parser.hs deleted file mode 100644 --- a/src/Theory/Text/Parser.hs +++ /dev/null @@ -1,668 +0,0 @@ --- | --- Copyright : (c) 2010-2012 Simon Meier, Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : portable --- --- Parsing protocol theories. See the MANUAL for a high-level description of --- the syntax. -module Theory.Text.Parser ( - parseOpenTheory - , parseOpenTheoryString - , parseLemma - , parseIntruderRulesDH - - -- * Cached Message Deduction Rule Variants - , intruderVariantsFile - , addMessageDeductionRuleVariants - ) where - -import Prelude hiding (id, (.)) - -import qualified Data.ByteString.Char8 as BC -import Data.Char (isUpper, toUpper) -import Data.Foldable (asum) -import Data.Label -import qualified Data.Map as M -import Data.Monoid hiding (Last) -import qualified Data.Set as S - -import Control.Applicative hiding (empty, many, optional) -import Control.Category -import Control.Monad - -import Extension.Prelude (ifM) - -import Text.Parsec hiding ((<|>)) -import Text.PrettyPrint.Class (render) - -import Paths_tamarin_prover -import System.Directory - -import Term.Substitution -import Term.SubtermRule -import Theory -import Theory.Text.Parser.Token -import Theory.Tools.IntruderRules - - - - - - ------------------------------------------------------------------------------- --- Lexing and parsing theory files and proof methods ------------------------------------------------------------------------------- - --- | Parse a security protocol theory file. -parseOpenTheory :: [String] -- ^ Defined flags - -> 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 from a string. -parseOpenTheoryString :: [String] -- ^ Defined flags. - -> String -> Either ParseError OpenTheory -parseOpenTheoryString flags = parseFromString (theory flags) - --- | Parse a lemma for an open theory from a string. -parseLemma :: String -> Either ParseError (Lemma ProofSkeleton) -parseLemma = parseFromString lemma - ------------------------------------------------------------------------------- --- Parsing Terms ------------------------------------------------------------------------------- - --- | Parse an lit with logical variables. -llit :: Parser LNTerm -llit = asum [freshTerm <$> freshName, pubTerm <$> pubName, varTerm <$> msgvar] - --- | Lookup the arity of a non-ac symbol. Fails with a sensible error message --- if the operator is not known. -lookupNonACArity :: String -> Parser Int -lookupNonACArity op = do - maudeSig <- getState - 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 :: Ord l => Parser (Term l) -> Parser (Term l) -naryOpApp plit = do - op <- identifier - k <- lookupNonACArity op - ts <- parens $ if k == 1 - then return <$> tupleterm plit - else commaSep (multterm plit) - let k' = length ts - when (k /= k') $ - fail $ "operator `" ++ op ++"' has arity " ++ show k ++ - ", but here it is used with arity " ++ show k' - return $ fAppNonAC (BC.pack op, k') ts - --- | Parse a binary operator written as @op{arg1}arg2@. -binaryAlgApp :: Ord l => Parser (Term l) -> Parser (Term l) -binaryAlgApp plit = do - op <- identifier - k <- lookupNonACArity op - arg1 <- braced (tupleterm plit) - arg2 <- term plit - when (k /= 2) $ fail $ - "only operators of arity 2 can be written using the `op{t1}t2' notation" - return $ fAppNonAC (BC.pack op, 2) [arg1, arg2] - --- | Parse a term. -term :: Ord l => Parser (Term l) -> Parser (Term l) -term plit = asum - [ pairing "pairs" - , parens (multterm plit) - , symbol "1" *> pure fAppOne - , application "function application" - , nullaryApp - , plit - ] - "term" - where - application = asum $ map (try . ($ plit)) [naryOpApp, binaryAlgApp] - pairing = angled (tupleterm plit) - nullaryApp = do - maudeSig <- getState - -- FIXME: This try should not be necessary. - asum [ try (symbol (BC.unpack sym)) *> pure (fApp (NonAC (sym,0)) []) - | (sym,0) <- S.toList $ allFunctionSymbols maudeSig ] - --- | A left-associative sequence of exponentations. -expterm :: Ord l => Parser (Term l) -> Parser (Term l) -expterm plit = chainl1 (term plit) ((\a b -> fAppExp (a,b)) <$ opExp) - --- | A left-associative sequence of multiplications. -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]) <$ opMult) - else term plit - --- | A right-associative sequence of tuples. -tupleterm :: Ord l => Parser (Term l) -> Parser (Term l) -tupleterm plit = chainr1 (multterm plit) ((\a b -> fAppPair (a,b)) <$ comma) - --- | Parse a fact. -fact :: Ord l => Parser (Term l) -> Parser (Fact (Term l)) -fact plit = try ( - do multi <- option Linear (opBang *> 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 (commaSep (multterm plit)) - mkProtoFact multi i ts - "fact" ) - where - singleTerm _ constr [t] = return $ constr t - singleTerm f _ ts = fail $ "fact '" ++ f ++ "' used with arity " ++ - show (length ts) ++ " instead of arity one" - - mkProtoFact multi f = case map toUpper f of - "OUT" -> singleTerm f outFact - "IN" -> singleTerm f inFact - "KU" -> singleTerm f kuFact - "KD" -> return . Fact KDFact - "DED" -> return . Fact DedFact - "FR" -> singleTerm f freshFact - _ -> return . protoFact multi f - - ------------------------------------------------------------------------------- --- Parsing Rules ------------------------------------------------------------------------------- - --- | Parse a "(modulo ..)" information. -modulo :: String -> Parser () -modulo thy = parens $ symbol_ "modulo" *> symbol_ thy - -moduloE, moduloAC :: Parser () -moduloE = modulo "E" -moduloAC = modulo "AC" - -{- --- | Parse a typing assertion modulo E. -typeAssertions :: Parser TypingE -typeAssertions = fmap TypingE $ - do try (symbols ["type", "assertions"]) - optional moduloE - colon - many1 ((,) <$> (try (msgvar <* colon)) - <*> ( commaSep1 (try $ multterm llit) <|> - (opMinus *> pure []) - ) - ) - <|> pure [] --} - --- | Parse a protocol rule. For the special rules 'Reveal_fresh', 'Fresh', --- 'Knows', and 'Learn' no rule is returned as the default theory already --- contains them. -protoRule :: Parser (ProtoRuleE) -protoRule = do - name <- try (symbol "rule" *> optional moduloE *> identifier <* colon) - subst <- option emptySubst letBlock - (ps,as,cs) <- genericRule - return $ apply subst $ Rule (StandRule name) ps cs as - --- | Parse a let block with bottom-up application semantics. -letBlock :: Parser LNSubst -letBlock = do - toSubst <$> (symbol "let" *> many1 definition <* symbol "in") - where - toSubst = foldr1 compose . map (substFromList . return) - definition = (,) <$> (sortedLVar [LSortMsg] <* equalSign) <*> multterm llit - --- | Parse an intruder rule. -intrRule :: Parser IntrRuleAC -intrRule = do - info <- try (symbol "rule" *> moduloAC *> intrInfo <* colon) - (ps,as,cs) <- genericRule - return $ Rule info ps cs as - where - intrInfo = do - name <- identifier - case name of - 'c':cname -> return $ ConstrRule (BC.pack cname) - 'd':dname -> return $ DestrRule (BC.pack dname) - _ -> fail $ "invalid intruder rule name '" ++ name ++ "'" - -genericRule :: Parser ([LNFact], [LNFact], [LNFact]) -genericRule = - (,,) <$> list (fact llit) - <*> ((pure [] <* symbol "-->") <|> - (symbol "--[" *> commaSep (fact llit) <* symbol "]->")) - <*> list (fact llit) - -{- --- | Add facts to a rule. -addFacts :: String -- ^ Command to be used: add_concs, add_prems - -> Parser (String, [LNFact]) -addFacts cmd = - (,) <$> (symbol cmd *> identifier <* colon) <*> commaSep1 fact --} - ------------------------------------------------------------------------------- --- Parsing transfer notation ------------------------------------------------------------------------------- - -{- --- | Parse an lit with strings for both constants as well as variables. -tlit :: Parser TTerm -tlit = asum - [ constTerm <$> singleQuoted identifier - , varTerm <$> identifier - ] - --- | Parse a single transfer. -transfer :: Parser Transfer -transfer = do - tf <- (\l -> Transfer l Nothing Nothing) <$> identifier <* kw DOT - (do right <- kw RIGHTARROW *> identifier <* colon - desc <- transferDesc - return $ tf { tfRecv = Just (desc right) } - <|> - do right <- kw LEFTARROW *> identifier <* colon - descr <- transferDesc - (do left <- try $ identifier <* kw LEFTARROW <* colon - descl <- transferDesc - return $ tf { tfSend = Just (descr right) - , tfRecv = Just (descl left) } - <|> - do return $ tf { tfSend = Just (descr right) } - ) - <|> - do left <- identifier - (do kw RIGHTARROW - (do right <- identifier <* colon - desc <- transferDesc - return $ tf { tfSend = Just (desc left) - , tfRecv = Just (desc right) } - <|> - do descl <- colon *> transferDesc - (do right <- kw RIGHTARROW *> identifier <* colon - descr <- transferDesc - return $ tf { tfSend = Just (descl left) - , tfRecv = Just (descr right) } - <|> - do return $ tf { tfSend = Just (descl left) } - ) - ) - <|> - do kw LEFTARROW - (do desc <- colon *> transferDesc - return $ tf { tfRecv = Just (desc left) } - <|> - do right <- identifier <* colon - desc <- transferDesc - return $ tf { tfSend = Just (desc right) - , tfRecv = Just (desc left) } - ) - ) - ) - where - transferDesc = do - ts <- tupleterm tlit - moreConcs <- (symbol "note" *> many1 (try $ fact tlit)) - <|> pure [] - types <- typeAssertions - return $ \a -> TransferDesc a ts moreConcs types - - --- | Parse a protocol in transfer notation -transferProto :: Parser [ProtoRuleE] -transferProto = do - name <- symbol "anb-proto" *> identifier - braced (convTransferProto name <$> abbrevs <*> many1 transfer) - where - abbrevs = (symbol "let" *> many1 abbrev) <|> pure [] - abbrev = (,) <$> try (identifier <* kw EQUAL) <*> multterm tlit - --} - ------------------------------------------------------------------------------- --- Parsing Standard and Guarded Formulas ------------------------------------------------------------------------------- - --- | Parse an atom with possibly bound logical variables. -blatom :: Parser BLAtom -blatom = (fmap (fmapTerm (fmap Free))) <$> asum - [ Last <$> try (symbol "last" *> parens nodevarTerm) "last atom" - , flip Action <$> try (fact llit <* opAt) <*> nodevarTerm "action atom" - , Less <$> try (nodevarTerm <* opLess) <*> nodevarTerm "less atom" - , EqE <$> try (multterm llit <* opEqual) <*> multterm llit "term equality" - , EqE <$> (nodevarTerm <* opEqual) <*> nodevarTerm "node equality" - ] - where - nodevarTerm = (lit . Var) <$> nodevar - --- | Parse an atom of a formula. -fatom :: Parser LNFormula -fatom = asum - [ pure lfalse <* opLFalse - , pure ltrue <* opLTrue - , Ato <$> try blatom - , quantification - , parens iff - ] - where - quantification = do - q <- (pure forall <* opForall) <|> (pure exists <* opExists) - vs <- many1 lvar <* dot - f <- iff - return $ foldr (hinted q) f vs - - hinted :: ((String, LSort) -> LVar -> a) -> LVar -> a - hinted f v@(LVar n s _) = f (n,s) v - - - --- | Parse a negation. -negation :: Parser LNFormula -negation = opLNot *> (Not <$> fatom) <|> fatom - --- | Parse a left-associative sequence of conjunctions. -conjuncts :: Parser LNFormula -conjuncts = chainl1 negation ((.&&.) <$ opLAnd) - --- | Parse a left-associative sequence of disjunctions. -disjuncts :: Parser LNFormula -disjuncts = chainl1 conjuncts ((.||.) <$ opLOr) - --- | An implication. -imp :: Parser LNFormula -imp = do - lhs <- disjuncts - asum [ opImplies *> ((lhs .==>.) <$> imp) - , pure lhs ] - --- | An logical equivalence. -iff :: Parser LNFormula -iff = do - lhs <- imp - asum [opLEquiv *> ((lhs .<=>.) <$> imp), pure lhs ] - --- | Parse a standard formula. -standardFormula :: Parser LNFormula -standardFormula = iff - --- | Parse a guarded formula using the hack of parsing a standard formula and --- converting it afterwards. --- --- FIXME: Write a proper parser. -guardedFormula :: Parser LNGuarded -guardedFormula = try $ do - res <- formulaToGuarded <$> standardFormula - case res of - Left d -> fail $ render d - Right gf -> return gf - - ------------------------------------------------------------------------------- --- Parsing Axioms ------------------------------------------------------------------------------- - --- | Parse an axiom. -axiom :: Parser Axiom -axiom = Axiom <$> (symbol "axiom" *> identifier <* colon) - <*> doubleQuoted standardFormula - - ------------------------------------------------------------------------------- --- Parsing Lemmas ------------------------------------------------------------------------------- - --- | Parse a 'LemmaAttribute'. -lemmaAttribute :: Parser LemmaAttribute -lemmaAttribute = asum - [ symbol "typing" *> pure TypingLemma - , symbol "reuse" *> pure ReuseLemma - , symbol "use_induction" *> pure InvariantLemma - ] - --- | Parse a 'TraceQuantifier'. -traceQuantifier :: Parser TraceQuantifier -traceQuantifier = asum - [ symbol "all-traces" *> pure AllTraces - , symbol "exists-trace" *> pure ExistsTrace - ] - --- | Parse a lemma. -lemma :: Parser (Lemma ProofSkeleton) -lemma = skeletonLemma <$> (symbol "lemma" *> optional moduloE *> identifier) - <*> (option [] $ list lemmaAttribute) - <*> (colon *> option AllTraces traceQuantifier) - <*> doubleQuoted standardFormula - <*> (proofSkeleton <|> pure (unproven ())) - - ------------------------------------------------------------------------------- --- Parsing Proofs ------------------------------------------------------------------------------- - --- | Parse a node premise. -nodePrem :: Parser NodePrem -nodePrem = parens ((,) <$> nodevar - <*> (comma *> fmap (PremIdx . fromIntegral) natural)) - --- | Parse a node conclusion. -nodeConc :: Parser NodeConc -nodeConc = parens ((,) <$> nodevar - <*> (comma *> fmap (ConcIdx .fromIntegral) natural)) - --- | Parse a goal. -goal :: Parser Goal -goal = asum - [ premiseGoal - , actionGoal - , chainGoal - , disjSplitGoal - , eqSplitGoal - ] - where - actionGoal = do - fa <- try (fact llit <* opAt) - i <- nodevar - return $ ActionG i fa - - premiseGoal = do - (fa, v) <- try ((,) <$> fact llit <*> opRequires) - i <- nodevar - return $ PremiseG (i, v) fa - - chainGoal = ChainG <$> (try (nodeConc <* opChain)) <*> nodePrem - - disjSplitGoal = (DisjG . Disj) <$> sepBy1 guardedFormula (symbol "∥") - - eqSplitGoal = try $ do - symbol_ "split" - parens $ (SplitG . SplitId . fromIntegral) <$> natural - - --- | Parse a proof method. -proofMethod :: Parser ProofMethod -proofMethod = asum - [ symbol "sorry" *> pure (Sorry Nothing) - , symbol "simplify" *> pure Simplify - , symbol "solve" *> (SolveGoal <$> parens goal) - , symbol "contradiction" *> pure (Contradiction Nothing) - , symbol "induction" *> pure Induction - ] - --- | Parse a proof skeleton. -proofSkeleton :: Parser ProofSkeleton -proofSkeleton = - solvedProof <|> finalProof <|> interProof - where - solvedProof = - symbol "SOLVED" *> pure (LNode (ProofStep Solved ()) M.empty) - - finalProof = do - method <- symbol "by" *> proofMethod - return (LNode (ProofStep method ()) M.empty) - - interProof = do - method <- proofMethod - cases <- (sepBy oneCase (symbol "next") <* symbol "qed") <|> - ((return . (,) "") <$> proofSkeleton ) - return (LNode (ProofStep method ()) (M.fromList cases)) - - oneCase = (,) <$> (symbol "case" *> identifier) <*> proofSkeleton - ------------------------------------------------------------------------------- --- Parsing Signatures ------------------------------------------------------------------------------- - --- | Builtin signatures. -builtins :: Parser () -builtins = - symbol "builtins" *> colon *> commaSep1 builtinTheory *> pure () - where - extendSig msig = modifyState (`mappend` msig) - builtinTheory = asum - [ try (symbol "diffie-hellman") - *> extendSig dhMaudeSig - , try (symbol "symmetric-encryption") - *> extendSig symEncMaudeSig - , try (symbol "asymmetric-encryption") - *> extendSig asymEncMaudeSig - , try (symbol "signing") - *> extendSig signatureMaudeSig - , symbol "hashing" - *> extendSig hashMaudeSig - ] - -functions :: Parser () -functions = - symbol "functions" *> colon *> commaSep1 functionSymbol *> pure () - where - functionSymbol = do - f <- BC.pack <$> identifier <* opSlash - k <- fromIntegral <$> natural - sig <- getState - case lookup f (S.toList $ allFunctionSymbols sig) of - Just k' | k' /= k -> - fail $ "conflicting arities " ++ - show k' ++ " and " ++ show k ++ - " for `" ++ BC.unpack f - _ -> setState (addFunctionSymbol (f,k) sig) - -equations :: Parser () -equations = - symbol "equations" *> colon *> commaSep1 equation *> pure () - where - equation = do - rrule <- RRule <$> term llit <*> (equalSign *> term llit) - case rRuleToStRule rrule of - Just str -> - modifyState (addStRule str) - Nothing -> - fail $ "Not a subterm rule: " ++ show rrule - ------------------------------------------------------------------------------- --- Parsing Theories ------------------------------------------------------------------------------- - - --- | Parse a theory. -theory :: [String] -- ^ Defined flags. - -> Parser OpenTheory -theory flags0 = do - symbol_ "theory" - thyId <- identifier - symbol_ "begin" - *> addItems (S.fromList flags0) (set thyName thyId defaultOpenTheory) - <* symbol "end" - where - addItems :: S.Set String -> OpenTheory -> Parser OpenTheory - addItems flags thy = asum - [ do builtins - msig <- getState - addItems flags $ set (sigpMaudeSig . thySignature) msig thy - , do functions - msig <- getState - addItems flags $ set (sigpMaudeSig . thySignature) msig thy - , do equations - msig <- getState - addItems flags $ set (sigpMaudeSig . thySignature) msig thy --- , do thy' <- foldM liftedAddProtoRule thy =<< transferProto --- addItems flags thy' - , do thy' <- liftedAddAxiom thy =<< axiom - addItems flags thy' - , do thy' <- liftedAddLemma thy =<< lemma - addItems flags thy' - , do ru <- protoRule - thy' <- liftedAddProtoRule thy ru - addItems flags thy' - , do r <- intrRule - addItems flags (addIntrRuleACs [r] thy) - , do c <- formalComment - addItems flags (addFormalComment c thy) - , do ifdef flags thy - , do define flags thy - , do return thy - ] - - define :: S.Set String -> OpenTheory -> Parser OpenTheory - define flags thy = do - flag <- try (symbol "#define") *> identifier - addItems (S.insert flag flags) thy - - ifdef :: S.Set String -> OpenTheory -> Parser OpenTheory - ifdef flags thy = do - flag <- symbol_ "#ifdef" *> identifier - thy' <- addItems flags thy - symbol_ "#endif" - if flag `S.member` flags - then addItems flags thy' - else addItems flags thy - - liftedAddProtoRule thy ru = case addProtoRule ru thy of - Just thy' -> return thy' - Nothing -> fail $ "duplicate rule: " ++ render (prettyRuleName ru) - - liftedAddLemma thy lem = case addLemma lem thy of - Just thy' -> return thy' - Nothing -> fail $ "duplicate lemma: " ++ get lName lem - - liftedAddAxiom thy ax = case addAxiom ax thy of - Just thy' -> return thy' - Nothing -> fail $ "duplicate axiom: " ++ get axName ax - - ------------------------------------------------------------------------------- --- Message deduction variants cached in files ------------------------------------------------------------------------------- - --- | The name of the intruder variants file. -intruderVariantsFile :: FilePath -intruderVariantsFile = "intruder_variants_dh.spthy" - --- | Add the variants of the message deduction rule. Uses the cached version --- of the @"intruder_variants_dh.spthy"@ file for the variants of the message --- deduction rules for Diffie-Hellman exponentiation. -addMessageDeductionRuleVariants :: OpenTheory -> IO OpenTheory -addMessageDeductionRuleVariants thy0 - | enableDH msig = do - variantsFile <- getDataFileName intruderVariantsFile - ifM (doesFileExist variantsFile) - (do dhVariants <- parseIntruderRulesDH variantsFile - return $ addIntrRuleACs dhVariants thy - ) - (error $ "could not find intruder message deduction theory '" - ++ variantsFile ++ "'") - | otherwise = return thy - where - msig = get (sigpMaudeSig . thySignature) thy0 - rules = subtermIntruderRules msig ++ specialIntruderRules - thy = addIntrRuleACs rules thy0 diff --git a/src/Theory/Text/Parser/Token.hs b/src/Theory/Text/Parser/Token.hs deleted file mode 100644 --- a/src/Theory/Text/Parser/Token.hs +++ /dev/null @@ -1,398 +0,0 @@ -{-# LANGUAGE TupleSections #-} --- | --- Copyright : (c) 2010-2012 Simon Meier, Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : portable --- --- Tokenizing infrastructure -module Theory.Text.Parser.Token ( - -- * Symbols - symbol - , symbol_ - , dot - , comma - , colon - - , natural - , naturalSubscript - - -- ** Formal comments - , formalComment - - -- * Identifiers and Variables - , identifier - , indexedIdentifier - - , freshName - , pubName - - , sortedLVar - , lvar - , msgvar - , nodevar - - -- * Operators - , opExp - , opMult - - , opEqual - , opLess - , opAt - , opForall - , opExists - , opImplies - , opLEquiv - , opLAnd - , opLOr - , opLNot - , opLFalse - , opLTrue - - , opRequires - , opChain - - -- ** Pseudo operators - , equalSign - , opSharp - , opBang - , opSlash - , opMinus - , opLeftarrow - , opRightarrow - , opLongleftarrow - , opLongrightarrow - - -- * Parentheses/quoting - , braced - , parens - , angled - , brackets - , singleQuoted - , doubleQuoted - - -- * List parsing - , commaSep - , commaSep1 - , list - - -- * Basic Parsing - , Parser - , parseFile - , parseFromString - ) where - -import Prelude hiding (id, (.)) - -import Data.Foldable (asum) -import Data.List (foldl') - -import Control.Applicative hiding (empty, many, optional) -import Control.Category -import Control.Monad - -import Text.Parsec hiding ((<|>)) -import qualified Text.Parsec.Token as T - -import Theory - - - - - - ------------------------------------------------------------------------------- --- Parser ------------------------------------------------------------------------------- - --- | A parser for a stream of tokens. -type Parser a = Parsec String MaudeSig a - --- Use Parsec's support for defining token parsers. -spthy :: T.TokenParser MaudeSig -spthy = - T.makeTokenParser spthyStyle - where - spthyStyle = T.LanguageDef - { T.commentStart = "/*" - , T.commentEnd = "*/" - , T.commentLine = "//" - , T.nestedComments = True - , T.identStart = alphaNum - , T.identLetter = alphaNum <|> oneOf "_" - , T.reservedNames = ["in","let","rule"] - , T.opStart = oneOf ":!$%&*+./<=>?@\\^|-" - , T.opLetter = oneOf ":!$%&*+./<=>?@\\^|-" - , T.reservedOpNames= [] - , T.caseSensitive = True - } - --- | Parse a file. -parseFile :: Parser a -> FilePath -> IO a -parseFile parser f = do - s <- readFile f - case runParser (T.whiteSpace spthy *> parser) minimalMaudeSig f s of - Right p -> return p - Left err -> error $ show err - --- | Run a given parser on a given string. -parseFromString :: Parser a -> String -> Either ParseError a -parseFromString parser = - runParser (T.whiteSpace spthy *> parser) minimalMaudeSig dummySource - where - dummySource = "" - - --- Token parsers ----------------- - --- | Parse a symbol. -symbol :: String -> Parser String -symbol sym = try (T.symbol spthy sym) ("\"" ++ sym ++ "\"") - --- | Parse a symbol without returning the parsed string. -symbol_ :: String -> Parser () -symbol_ = void . symbol - --- | Between braces. -braced :: Parser a -> Parser a -braced = T.braces spthy - --- | Between brackets. -brackets :: Parser a -> Parser a -brackets = T.brackets spthy - --- | Between parentheses. -parens :: Parser a -> Parser a -parens = T.parens spthy - --- | Between angular brackets. -angled :: Parser a -> Parser a -angled = T.angles spthy - --- | Between single quotes. -singleQuoted :: Parser a -> Parser a -singleQuoted = between (symbol "'") (symbol "'") - --- | Between double quotes. -doubleQuoted :: Parser a -> Parser a -doubleQuoted = between (symbol "\"") (symbol "\"") - --- | A dot @.@. -dot :: Parser () -dot = void $ T.dot spthy - --- | A comma @,@. -comma :: Parser () -comma = void $ T.comma spthy - --- | A colon @:@. -colon :: Parser () -colon = void $ T.colon spthy - --- | Parse an natural. -natural :: Parser Integer -natural = T.natural spthy - --- | Parse a Unicode-subscripted natural number. -naturalSubscript :: Parser Integer -naturalSubscript = T.lexeme spthy $ do - digits <- many1 (oneOf "₀₁₂₃₄₅₆₇₈₉") - let n = foldl' (\x d -> 10*x + subscriptDigitToInteger d) 0 digits - seq n (return n) - where - subscriptDigitToInteger d = toInteger $ fromEnum d - fromEnum '₀' - --- | A comma separated list of elements. -commaSep :: Parser a -> Parser [a] -commaSep = T.commaSep spthy - --- | A comma separated non-empty list of elements. -commaSep1 :: Parser a -> Parser [a] -commaSep1 = T.commaSep1 spthy - --- | Parse a list of items '[' item ',' ... ',' item ']' -list :: Parser a -> Parser [a] -list = brackets . commaSep - --- | A formal comment; i.e., (header, body) -formalComment :: Parser (String, String) -formalComment = T.lexeme spthy $ do - header <- try (many1 letter <* string "{*") - body <- many bodyChar <* string "*}" - return (header, body) - where - bodyChar = try $ do - c <- anyChar - case c of - '\\' -> char '\\' <|> char '*' - '*' -> mzero - _ -> return c - --- Identifiers and Variables ----------------------------- - --- | Parse an identifier as a string -identifier :: Parser String -identifier = T.identifier spthy - --- | Parse an identifier possibly indexed with a number. -indexedIdentifier :: Parser (String, Integer) -indexedIdentifier = do - (,) <$> identifier - <*> option 0 (try (dot *> (fromIntegral <$> natural))) - --- | Parse a logical variable with the given sorts allowed. -sortedLVar :: [LSort] -> Parser LVar -sortedLVar ss = - asum $ map (try . mkSuffixParser) ss ++ map mkPrefixParser ss - where - mkSuffixParser s = do - (n, i) <- indexedIdentifier <* colon - symbol_ (sortSuffix s) - return (LVar n s i) - - mkPrefixParser s = do - case s of - LSortMsg -> pure () - LSortPub -> void $ char '$' - LSortFresh -> void $ char '~' - LSortNode -> void $ char '#' - LSortMSet -> void $ char '%' - (n, i) <- indexedIdentifier - return (LVar n s i) - --- | An arbitrary logical variable. -lvar :: Parser LVar -lvar = sortedLVar [minBound..] - --- | Parse a non-node variable. -msgvar :: Parser LVar -msgvar = sortedLVar [LSortFresh, LSortPub, LSortMsg, LSortMSet] - --- | Parse a graph node variable. -nodevar :: Parser NodeId -nodevar = asum - [ sortedLVar [LSortNode] - , (\(n, i) -> LVar n LSortNode i) <$> indexedIdentifier ] - "timepoint variable" - --- | Parse a literal fresh name, e.g., @~'n'@. -freshName :: Parser String -freshName = try (symbol "~" *> singleQuoted identifier) - --- | Parse a literal public name, e.g., @'n'@. -pubName :: Parser String -pubName = singleQuoted identifier - - --- Term Operators ------------- - --- | The exponentiation operator @^@. -opExp :: Parser () -opExp = symbol_ "^" - --- | The multiplication operator @*@. -opMult :: Parser () -opMult = symbol_ "*" - --- | The timepoint comparison operator @<@. -opLess :: Parser () -opLess = symbol_ "<" - --- | The action-at-timepoint operator \@. -opAt :: Parser () -opAt = symbol_ "@" - --- | The equality operator @=@. -opEqual :: Parser () -opEqual = symbol_ "=" - --- | The logical-forall operator @All@ or @∀@. -opForall :: Parser () -opForall = symbol_ "All" <|> symbol_ "∀" - --- | The logical-exists operator @Ex@ or @∃@. -opExists :: Parser () -opExists = symbol_ "Ex" <|> symbol_ "∃" - --- | The logical-implies operator @==>@. -opImplies :: Parser () -opImplies = symbol_ "==>" <|> symbol_ "⇒" - --- | The logical-equivalence operator @<=>@. -opLEquiv :: Parser () -opLEquiv = symbol_ "<=>" <|> symbol_ "⇔" - --- | The logical-and operator @&@ or @∧@. -opLAnd :: Parser () -opLAnd = symbol_ "&" <|> symbol_ "∧" - --- | The logical-or operator @|@ or @∨@. -opLOr :: Parser () -opLOr = symbol_ "|" <|> symbol_ "∨" - --- | The logical not operator @not@ or @¬@. -opLNot :: Parser () -opLNot = symbol_ "¬" <|> symbol_ "not" - --- | A logical false, @F@ or @⊥@. -opLFalse :: Parser () -opLFalse = symbol_ "⊥" <|> T.reserved spthy "F" - --- | A logical false, @T@ or @⊥@. -opLTrue :: Parser () -opLTrue = symbol_ "⊤" <|> T.reserved spthy "T" - --- Operators for constraints ----------------------------- - --- | The requires-a-premise operator, @▶ subscript-idx@. -opRequires :: Parser PremIdx -opRequires = (PremIdx . fromIntegral) <$> (symbol "▶" *> naturalSubscript) - --- | The chain operator @~~>@. -opChain :: Parser () -opChain = symbol_ "~~>" - - --- Pseudo operators (to be replaced by usage of proper tokens) --------------------------------------------------------------- - --- | The equal sign @=@. -equalSign :: Parser () -equalSign = symbol_ "=" - --- | The slash operator @/@. -opSlash :: Parser () -opSlash = symbol_ "/" - --- | The bang operator @!@. -opBang :: Parser () -opBang = symbol_ "!" - --- | The sharp operator @#@. -opSharp :: Parser () -opSharp = symbol_ "#" - --- | The minus operator @-@. -opMinus :: Parser () -opMinus = symbol_ "-" - --- | The leftarrow operator @<--@. -opLeftarrow :: Parser () -opLeftarrow = symbol_ "<-" - --- | The rightarrow operator @-->@. -opRightarrow :: Parser () -opRightarrow = symbol_ "->" - --- | The longleftarrow operator @<--@. -opLongleftarrow :: Parser () -opLongleftarrow = symbol_ "<--" - --- | The longrightarrow operator @-->@. -opLongrightarrow :: Parser () -opLongrightarrow = symbol_ "-->" diff --git a/src/Theory/Text/Parser/UnitTests.hs b/src/Theory/Text/Parser/UnitTests.hs deleted file mode 100644 --- a/src/Theory/Text/Parser/UnitTests.hs +++ /dev/null @@ -1,91 +0,0 @@ --- | --- Copyright : (c) 2012 Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- --- Unit tests for checking that all examples parse properly. -module Theory.Text.Parser.UnitTests ( - - testParseFile - , testParseDirectory - ) where - -import Test.HUnit - -import Control.Basics - -import System.Directory -import System.FilePath - -import Theory -import Theory.Text.Parser -import Theory.Text.Pretty (render) - --- | Test wether a given file exists, can be parsed, and can still be parsed --- after being pretty printed. -testParseFile :: Maybe (FilePath, Prover) - -- ^ Path to maude and prover for testing whether proof parsing - -- works properly. - -> FilePath - -- ^ File on which to test parsing (and proving) - -> Test -testParseFile optionalProver inpFile = TestLabel inpFile $ TestCase $ do - thyString <- readFile inpFile - thy0 <- parse "original file:" thyString - -- add proofs and pretty print closed theory, if desired - (thy, thyPretty) <- case optionalProver of - Nothing -> - return (thy0, prettyOpenTheory thy0) - Just (maudePath, prover) -> do - closedThy <- proveTheory prover <$> closeTheory maudePath thy0 - return $ ( normalizeTheory $ openTheory closedThy - , prettyClosedTheory closedThy) - thy' <- parse "pretty printed theory:" (render thyPretty) - unless (thy == thy') $ do - let (diff1, diff2) = - unzip $ dropWhile (uncurry (==)) $ zip (show thy) (show thy') - assertFailure $ unlines - [ "Original theory", "", render (prettyOpenTheory thy), "" - , "Pretty printed and parsed" , "", render (prettyOpenTheory thy'), "" - , "Original theory (diff)", "", indent diff1, "" - , "Pretty printed and parsed (diff)" , "", indent diff2, "", "DIFFER" - ] - return () - where - indent = unlines . map (' ' :) . lines - - parse msg str = case parseOpenTheoryString [] str of - Left err -> do assertFailure $ withLineNumbers $ indent $ show err - return (error "testParseFile: dead code") - Right thy -> normalizeTheory <$> addMessageDeductionRuleVariants thy - where - withLineNumbers err = - unlines $ zipWith (\i l -> nr (show i) ++ l) [(1::Int)..] ls - ++ ["", "Parse error when parsing the " ++ msg, err] - where - ls = lines str - n = length (show (length ls)) - nr i = replicate (1 + max 0 (n - length i)) ' ' ++ i ++ ": " - --- | Create the test whether 'testParseFile' succeeds on all @*.spthy@ files --- in a given directory and all its subdirectories of depth n. -testParseDirectory :: (FilePath -> Test) -- ^ Test creation function. - -> Int -- ^ Maximal depth of traversal. - -> FilePath -- ^ Starting directory. - -> IO [Test] -testParseDirectory mkTest n dir - | n < 0 = return [] - | otherwise = do - rawContents <- getDirectoryContents dir - let contents = [ dir content - | content <- rawContents - , content /= ".", content /= ".." ] - subDirs <- filterM doesDirectoryExist contents - innerTests <- mapM (testParseDirectory mkTest (n - 1)) subDirs - let tests = [ file - | file <- contents, takeExtension file == ".spthy" ] - mapM_ (putStrLn . (" peparing: " ++)) tests - return $ map mkTest tests ++ map TestList innerTests - - diff --git a/src/Theory/Text/Pretty.hs b/src/Theory/Text/Pretty.hs deleted file mode 100644 --- a/src/Theory/Text/Pretty.hs +++ /dev/null @@ -1,130 +0,0 @@ --- | --- Copyright : (c) 2011 Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : portable --- --- General support for pretty printing theories. -module Theory.Text.Pretty ( - -- * General highlighters - module Text.PrettyPrint.Highlight - - -- * Additional combinators - , vsep - , fsepList - - -- * Comments - , lineComment - , multiComment - - , lineComment_ - , multiComment_ - - -- * Keywords - , kwTheoryHeader - , kwEnd - , kwModulo - , kwBy - , kwCase - , kwNext - , kwQED - , kwLemma - , kwAxiom - - -- ** Composed forms - , kwRuleModulo - , kwInstanceModulo - , kwVariantsModulo - , kwTypesModulo - - -- * Operators - , opProvides - , opRequires - , opAction - , opPath - , opLess - , opEqual - , opDedBefore - , opEdge - - ) where - -import Text.PrettyPrint.Highlight - - ------------------------------------------------------------------------------- --- Additional combinators ------------------------------------------------------------------------------- - --- | Vertically separate a list of documents by empty lines. -vsep :: Document d => [d] -> d -vsep = foldr ($--$) emptyDoc - --- | Pretty print a list of values as a comma-separated list wrapped in --- paragraph mode. -fsepList :: Document d => (a -> d) -> [a] -> d -fsepList pp = fsep . punctuate comma . map pp - - ------------------------------------------------------------------------------- --- Comments ------------------------------------------------------------------------------- - -lineComment :: HighlightDocument d => d -> d -lineComment d = comment $ text "//" <-> d - -lineComment_ :: HighlightDocument d => String -> d -lineComment_ = lineComment . text - -multiComment :: HighlightDocument d => d -> d -multiComment d = comment $ fsep [text "/*", d, text "*/"] - -multiComment_ :: HighlightDocument d => [String] -> d -multiComment_ ls = comment $ fsep [text "/*", vcat $ map text ls, text "*/"] - ------------------------------------------------------------------------------- --- Keywords ------------------------------------------------------------------------------- - -kwTheoryHeader :: HighlightDocument d => d -> d -kwTheoryHeader name = keyword_ "theory" <-> name <-> keyword_ "begin" - -kwEnd, kwBy, kwCase, kwNext, kwQED, kwAxiom, kwLemma :: HighlightDocument d => d -kwEnd = keyword_ "end" -kwBy = keyword_ "by" -kwCase = keyword_ "case" -kwNext = keyword_ "next" -kwQED = keyword_ "qed" -kwAxiom = keyword_ "axiom" -kwLemma = keyword_ "lemma" - -kwModulo :: HighlightDocument d - => String -- ^ What - -> String -- ^ modulo theory - -> d -kwModulo what thy = keyword_ what <-> parens (keyword_ "modulo" <-> text thy) - -kwRuleModulo, kwInstanceModulo, kwTypesModulo, kwVariantsModulo - :: HighlightDocument d => String -> d -kwRuleModulo = kwModulo "rule" -kwInstanceModulo = kwModulo "instance" -kwTypesModulo = kwModulo "type assertions" -kwVariantsModulo = kwModulo "variants" - - ------------------------------------------------------------------------------- --- Operators ------------------------------------------------------------------------------- - -opProvides, opRequires, opAction, opPath, opLess, opEqual, opDedBefore, opEdge - :: HighlightDocument d => d -opProvides = operator_ ":>" -opRequires = operator_ "<:" -opAction = operator_ "@" -opPath = operator_ ">+>" -opLess = operator_ "<" -opEqual = operator_ "=" -opDedBefore = operator_ "--|" -opEdge = operator_ ">->" - diff --git a/src/Theory/Tools/AbstractInterpretation.hs b/src/Theory/Tools/AbstractInterpretation.hs deleted file mode 100644 --- a/src/Theory/Tools/AbstractInterpretation.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE 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.Tools.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.Label -import Data.List -import qualified Data.Set as S -import Data.Traversable (traverse) - -import Term.Substitution -import Theory.Model -import Theory.Text.Pretty - - ------------------------------------------------------------------------------- --- 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" - -{- FIXME: Implement - --- | Perform a simple propagation of sorts at the fact level. -propagateSorts :: [ProtoRuleE] - -> WithMaude (M.Map FactTag [LSort], [ProtoRuleE]) -propagateSorts ruEs = reader $ \hnd -> - --} diff --git a/src/Theory/Tools/EquationStore.hs b/src/Theory/Tools/EquationStore.hs deleted file mode 100644 --- a/src/Theory/Tools/EquationStore.hs +++ /dev/null @@ -1,566 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt, Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Benedikt Schmidt --- Portability : GHC only --- --- Support for reasoning with and about disjunctions of substitutions. -module Theory.Tools.EquationStore ( - -- * Equations - SplitId(..) - - , EqStore(..) - , emptyEqStore - , eqsSubst - , eqsConj - - -- ** Equalitiy constraint conjunctions - , falseEqConstrConj - - -- ** Queries - , eqsIsFalse - - - -- ** Adding equalities - , addEqs - , addRuleVariants - , addDisj - - -- ** Case splitting - , performSplit - - , splits - , splitSize - , splitExists - - -- * Simplification - , simp - , simpDisjunction - - -- ** Pretty printing - , prettyEqStore -) where - -import Logic.Connectives -import Term.Unification -import Theory.Text.Pretty - -import Control.Monad.Fresh -import Control.Monad.Reader -import Extension.Prelude -import Utils.Misc - -import Debug.Trace.Ignore - -import Control.Basics -import Control.DeepSeq -import Control.Monad.State hiding (get, modify, put) -import qualified Control.Monad.State as MS - -import Data.Binary -import Data.DeriveTH -import qualified Data.Foldable as F -import Data.List -import Data.Maybe -import qualified Data.Set as S -import Extension.Data.Label hiding (for, get) -import qualified Extension.Data.Label as L -import Extension.Data.Monoid - ------------------------------------------------------------------------------- --- Equation Store -- ------------------------------------------------------------------------------- - --- | Index of disjunction in equation store -newtype SplitId = SplitId { unSplitId :: Integer } - deriving( Eq, Ord, Show, Enum, Binary, NFData, HasFrees ) - --- FIXME: Make comment parse. --- --- The semantics of an equation store --- > EqStore sigma_free --- > [ [sigma_i1,..,sigma_ik_i] | i <- [1..l] ] --- where sigma_free = {t1/x1, .., tk/xk} is --- > (x1 = t1 /\ .. /\ xk = tk) --- > /\_{i in [1..l]} --- > ([|sigma_i1|] \/ .. \/ [|sigma_ik_1|] \/ [|mtinfo_i|] --- where @[|{t_1/x_1,..,t_l/x_l}|] = EX vars(t1,..,tl). x_1 = t1 /\ .. /\ x_l = t_l@. --- Note that the 'LVar's in the range of a substitution are interpreted as --- fresh variables, i.e., different by construction from the x_i which are --- free variables. --- --- The variables in the domain of the substitutions sigma_ij and all --- variables in sigma_free are free (usually globally existentially quantified). --- We use Conj [] as a normal form to denote True and Conj [Disj []] --- as a normal form to denote False. --- We say a variable @x@ is constrained by a disjunction if there is a substition --- @s@ in the disjunction with @x `elem` dom s@. -data EqStore = EqStore { - _eqsSubst :: LNSubst - , _eqsConj :: Conj (SplitId, S.Set LNSubstVFresh) - , _eqsNextSplitId :: SplitId - } - deriving( Eq, Ord ) - -$(mkLabels [''EqStore]) - --- | @emptyEqStore@ is the empty equation store. -emptyEqStore :: EqStore -emptyEqStore = EqStore emptySubst (Conj []) (SplitId 0) - --- | @True@ iff the 'EqStore' is contradictory. -eqsIsFalse :: EqStore -> Bool -eqsIsFalse = any ((S.empty == ) . snd) . getConj . L.get eqsConj - --- | The false conjunction. It is always identified with split number -1. -falseEqConstrConj :: Conj (SplitId, S.Set (LNSubstVFresh)) -falseEqConstrConj = Conj [ (SplitId (-1), S.empty) ] - - --- Instances ------------- - -instance Apply SplitId where - apply _ = id - -instance HasFrees EqStore where - foldFrees f (EqStore subst substs nextSplitId) = - foldFrees f subst <> foldFrees f substs <> foldFrees f nextSplitId - mapFrees f (EqStore subst substs nextSplitId) = - EqStore <$> mapFrees f subst - <*> mapFrees f substs - <*> mapFrees f nextSplitId - - - --- Equation Store ----------------------------------------------------------------------- - --- | We use the empty set (disjunction) to denote false. -falseDisj :: S.Set LNSubstVFresh -falseDisj = S.empty - - --- Dealing with equations ----------------------------------------------------------------------- - --- | Returns the list of all @SplitId@s valid for the given equation store --- sorted by the size of the disjunctions. -splits :: EqStore -> [SplitId] -splits eqs = map fst $ nub $ sortOn snd - [ (idx, S.size conj) | (idx, conj) <- getConj $ L.get eqsConj eqs ] - --- | Returns 'True' if the 'SplitId' is valid. -splitExists :: EqStore -> SplitId -> Bool -splitExists eqs = isJust . splitSize eqs - --- | Returns the number of cases for a given 'SplitId'. -splitSize :: EqStore -> SplitId -> Maybe Int -splitSize eqs sid = - (S.size . snd) <$> (find ((sid ==) . fst) $ getConj $ L.get eqsConj $ eqs) - --- | Add a disjunction to the equation store at the beginning -addDisj :: EqStore -> (S.Set LNSubstVFresh) -> (EqStore, SplitId) -addDisj eqStore disj = - ( modify eqsConj ((Conj [(sid, disj)]) `mappend`) - $ modify eqsNextSplitId succ - $ eqStore - , sid - ) - where - sid = L.get eqsNextSplitId eqStore - --- | @performSplit eqs i@ performs a case-split on the first disjunction --- with the given 'SplitId'. -performSplit :: EqStore -> SplitId -> Maybe [EqStore] -performSplit eqStore idx = - case break ((idx ==) . fst) (getConj $ L.get eqsConj eqStore) of - (_, []) -> Nothing - (before, (_, disj):after) -> Just $ - mkNewEqStore before after <$> S.toList disj - where - mkNewEqStore before after subst = - fst $ addDisj (set eqsConj (Conj (before ++ after)) eqStore) - (S.singleton subst) - --- | Add a list of term equalities to the equation store. Returns the split --- identifier of the disjunction in resulting equation store. -addEqs :: MonadFresh m - => MaudeHandle -> [Equal LNTerm] -> EqStore -> m (EqStore, Maybe SplitId) -addEqs hnd eqs0 eqStore = - case unifyLNTermFactored eqs `runReader` hnd of - (_, []) -> - return (set eqsConj falseEqConstrConj eqStore, Nothing) - (subst, [substFresh]) | substFresh == emptySubstVFresh -> - return (applyEqStore hnd subst eqStore, Nothing) - (subst, substs) -> do - let (eqStore', sid) = addDisj (applyEqStore hnd subst eqStore) - (S.fromList substs) - return (eqStore', Just sid) - {- - 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 (L.get eqsSubst eqStore) $ trace (unlines ["addEqs: ", show eqs0]) $ eqs0 - {- - 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 (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 $ "applyEqStore: dom and vrange not disjoint for `"++show asubst++"'" - | otherwise - = modify eqsConj (fmap (second (S.fromList . concatMap applyBound . S.toList))) $ - set eqsSubst newsubst eqStore - where - newsubst = asubst `compose` L.get eqsSubst eqStore - applyBound s = map (restrictVFresh (varsRange newsubst ++ domVFresh s)) $ - (`runReader` hnd) $ unifyLNTerm - [ 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 - -- NOTE: these variables never enter the global context - let ran = renameAvoiding (map snd slist) - (domVFresh s ++ varsRange newsubst), - (lv,t) <- zip (map fst slist) ran - ] - -{- NOTES for @applyEqStore tau@ to a fresh substitution sigma: -[ FIXME: extend explanation to multiple unifiers ] -Let dom(sigma) = x1,..,xk, vrange(sigma) = y1, .. yl, vrange(tau) = z1,..,zn -Fresh substitution denotes formula - exists #y1, .., #yl. x1 = t1 /\ .. /\ xk = tk -for variables #yi that do not clash with xi and zi [renameAwayFrom] -and with vars(ti) `subsetOf` [#y1, .. #yl]. -We apply tau with vrange(tau) = z1,..,zn to the formula to obtain - exists ##y1, .., ##yl. tau(x1) = t1 /\ .. /\ tau(xk) = tk -unification then yields a lemma - forall xi zi #yi. - tau(x1) = t1 /\ .. /\ tau(xk) = tk - <-> exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = .. -So we have - exists #y1, .., #yl. - exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = .. -<=> - exists vars(s1,..sm). x1 = .. /\ z1 = .. - /\ (exists #y1, .., #yl. #y1 = ..) -<=> [restric] - exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ True --} - --- | Add the given rule variants. -addRuleVariants :: Disj LNSubstVFresh -> EqStore -> (EqStore, SplitId) -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 (S.fromList substs) - where - freeSubst = L.get eqsSubst eqStore - - -{- --- | Return the set of variables that is constrained by disjunction at give position. -constrainedVarsPos :: EqStore -> Int -> [LVar] -constrainedVarsPos eqStore k - | k < length conj = frees (conj!!k) - | otherwise = [] - where - conj = getConj . L.get eqsConj $ eqStore --} - --- Simplifying disjunctions ----------------------------------------------------------------------- - --- | Simplify given disjunction via EqStore simplification. Obtains fresh --- names for variables from the underlying 'MonadFresh'. -simpDisjunction :: MonadFresh m - => MaudeHandle - -> (LNSubstVFresh -> Bool) - -> Disj LNSubstVFresh - -> m (LNSubst, Maybe [LNSubstVFresh]) -simpDisjunction hnd isContr disj0 = do - eqStore' <- simp hnd isContr eqStore - return (L.get eqsSubst eqStore', wrap $ L.get eqsConj eqStore') - where - eqStore = fst $ addDisj emptyEqStore (S.fromList $ getDisj $ disj0) - wrap (Conj []) = Nothing - wrap (Conj [(_, disj)]) = Just $ S.toList disj - wrap conj = - error ("simplifyDisjunction: imposible, unexpected conjunction `" - ++ show conj ++ "'") - - --- Simplification ----------------------------------------------------------------------- - --- | @simp eqStore@ simplifies the equation store. -simp :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> EqStore -> m EqStore -simp hnd isContr eqStore = - execStateT (whileTrue (simp1 hnd isContr)) - (trace (show ("eqStore", eqStore)) eqStore) - - --- | @simp1@ tries to execute one simplification step --- for the equation store. It returns @True@ if --- the equation store was modified. -simp1 :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> StateT EqStore m Bool -simp1 hnd isContr = do - s <- MS.get - 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 (L.get eqsConj) - if F.any (S.foldl' (\b subst -> b || domVFresh subst /= domVFresh (removeRenamings subst)) False . snd) conj - then modM eqsConj (fmap (second $ S.map removeRenamings)) >> 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 -simpEmptyDisj = do - conj <- getM eqsConj - if (F.any ((== falseDisj) . snd) conj && conj /= falseEqConstrConj) - then eqsConj =: falseEqConstrConj >> return True - else return False - - --- | If there is a singleton disjunction, it can be --- composed with the free substitution. -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 - => [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, [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, [S.fromList substs']) - (_, _ ,_):_ -> - error "simpAbstract: impossible, invalid arities or List operator encountered." - where - commonOperators = do - (v, viewTerm -> FApp o args) <- substToListVFresh subst - let images = map (\s -> imageOfVFresh s v) others - argss = [ args' | Just (viewTerm -> FApp o' args') <- images, o' == o ] - guard (length argss == length others) - return (v, o, args:argss) - - abstractAll v freshVars s args = substFromListVFresh $ - filter ((/= v) . fst) (substToListVFresh s) ++ zip freshVars args - - abstractTwo o v fv1 fv2 s args = substFromListVFresh $ - filter ((/= v) . fst) (substToListVFresh s) ++ newMappings args - where - newMappings [] = - error "simpAbstract: impossible, AC symbols must have arity >= 2." - 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)] - - --- | 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 - => [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)] - , [S.fromList (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))]) - where - commonNames = do - (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 - => [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)] - , [S.fromList (zipWith (replaceMapping v fv) lvs (subst:others))]) - where - commonSortedVar = do - (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 (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 - => [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)]), - [S.fromList (map (removeMappings [vkeep]) (subst:others))]) - where - equalImgPairs = do - (v,t) <- substToListVFresh subst - (v', t') <- substToListVFresh subst - guard (t == t' && v < v' && all (agrees_on v v') others) - return (v,v') - agrees_on v v' s = - imageOfVFresh s v == imageOfVFresh s v' && isJust (imageOfVFresh s v) - removeMappings vs s = restrictVFresh (domVFresh s \\ vs) s - - --- | 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 (L.get eqsConj) - if F.any (F.any check . snd) conj - then MS.modify (set eqsConj (fmap (second minimize) conj)) >> return True - else return False - where - minimize substs - | emptySubstVFresh `S.member` substs = S.singleton emptySubstVFresh - | otherwise = S.filter (not . isContr) substs - - check subst = subst == emptySubstVFresh || isContr subst - - --- | 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 - -> ([LNSubstVFresh] -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))) - -> StateT EqStore m Bool -foreachDisj hnd f = - go [] =<< gets (getConj . L.get eqsConj) - where - go _ [] = return False - go lefts ((idx,d):rights) = do - b <- lift $ f (S.toList d) - case b of - Nothing -> go ((idx,d):lefts) rights - Just (msubst, disjs) -> do - eqsConj =: Conj (reverse lefts ++ ((,) idx <$> disjs) ++ rights) - maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst - return True - ------------------------------------------------------------------------------- --- Pretty printing ------------------------------------------------------------------------------- - --- | Pretty print an 'EqStore'. -prettyEqStore :: HighlightDocument d => EqStore -> d -prettyEqStore eqs@(EqStore subst (Conj disjs) _nextSplitId) = vcat $ - [if eqsIsFalse eqs then text "CONTRADICTORY" else emptyDoc] ++ - map combine - [ ("subst", vcat $ prettySubst (text . show) (text . show) subst) - , ("conj", vcat $ map ppDisj disjs) - ] - where - combine (header, d) = fsep [keyword_ header <> colon, nest 2 d] - ppDisj (idx, substs) = - text (show (unSplitId idx)) <-> numbered' conjs - where - conjs = map ppConj (S.toList substs) - ppConj = vcat . map prettyEq . substToListVFresh - prettyEq (a,b) = - prettyNTerm (lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b) - - - --- Derived and delayed instances --------------------------------- - -instance Show EqStore where - show = render . prettyEqStore - -$( derive makeBinary ''EqStore) -$( derive makeNFData ''EqStore) diff --git a/src/Theory/Tools/InjectiveFactInstances.hs b/src/Theory/Tools/InjectiveFactInstances.hs deleted file mode 100644 --- a/src/Theory/Tools/InjectiveFactInstances.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | --- Copyright : (c) 2012 Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : portable --- --- Computate an under-approximation to the set of all facts with unique --- instances, i.e., fact whose instances never occur more than once in a --- state. We use this information to reason about protocols that exploit --- exclusivity of linear facts. -module Theory.Tools.InjectiveFactInstances ( - - -- * Computing injective fact instances. - simpleInjectiveFactInstances - ) where - -import Extension.Prelude (sortednub) - -import Control.Applicative -import Control.Monad.Fresh -import Data.Label -import qualified Data.Set as S -import Safe (headMay) - -import Theory.Model - --- | Compute a simple under-approximation to the set of facts with injective --- instances. A fact-tag is has injective instances, if there is no state of --- the protocol with more than one instance with the same term as a first --- argument of the fact-tag. --- --- We compute the under-approximation by checking that --- (1) the fact-tag is linear, --- (2) every introduction of such a fact-tag is protected by a Fr-fact of the --- first term, and --- (3) every rule has at most one copy of this fact-tag in the conlcusion and --- the first term arguments agree. --- --- We exclude facts that are not copied in a rule, as they are already handled --- properly by the naive backwards reasoning. -simpleInjectiveFactInstances :: [ProtoRuleE] -> S.Set FactTag -simpleInjectiveFactInstances rules = S.fromList $ do - tag <- candidates - guard (all (guardedSingletonCopy tag) rules) - return tag - where - candidates = sortednub $ do - ru <- rules - tag <- factTag <$> get rConcs ru - guard $ (factTagMultiplicity tag == Linear) - && (tag `elem` (factTag <$> get rPrems ru)) - return tag - - guardedSingletonCopy tag ru = - length copies <= 1 && all guardedCopy copies - where - prems = get rPrems ru - copies = filter ((tag ==) . factTag) (get rConcs ru) - firstTerm = headMay . factTerms - - -- True if there is a first term and a premise guarding it - guardedCopy faConc = case firstTerm faConc of - Nothing -> False - Just tConc -> freshFact tConc `elem` prems || guardedInPrems tConc - - -- True if there is a premise with the same tag and first term - guardedInPrems tConc = (`any` prems) $ \faPrem -> - factTag faPrem == tag && maybe False (tConc ==) (firstTerm faPrem) - diff --git a/src/Theory/Tools/IntruderRules.hs b/src/Theory/Tools/IntruderRules.hs deleted file mode 100644 --- a/src/Theory/Tools/IntruderRules.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - -- spurious warnings for view patterns --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Benedikt Schmidt --- Portability : GHC only --- -module Theory.Tools.IntruderRules ( - subtermIntruderRules - , dhIntruderRules - , specialIntruderRules - ) where - -import Control.Basics -import Control.Monad.Reader - -import Data.List -import qualified Data.Set as S - -import Extension.Data.Label - -import Utils.Misc - -import Term.Maude.Signature -import Term.Narrowing.Variants.Compute -import Term.Rewriting.Norm -import Term.SubtermRule -import Term.Positions - -import Theory.Model - - - --- Variants of intruder deduction rules ----------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- Special Intruder rules ------------------------------------------------------------------------------- - -{- -These are the special intruder that are always included. - -rule (modulo AC) coerce: - [ KD( f_, x ) ] --[ KU( f_, x) ]-> [ KU( f_, x ) ] - -rule (modulo AC) pub: - [ ] --[ KU( f_, $x) ]-> [ KU( f_, $x ) ] - -rule (modulo AC) gen_fresh: - [ Fr( ~x ) ] --[ KU( 'noexp', ~x ) ]-> [ KU( 'noexp', ~x ) ] - -rule (modulo AC) isend: - [ KU( f_, x) ] --[ K(x) ]-> [ In(x) ] - -rule (modulo AC) irecv: - [ Out( x) ] --> [ KD( 'exp', x) ] - --} --- | @specialIntruderRules@ returns the special intruder rules that are --- included independently of the message theory -specialIntruderRules :: [IntrRuleAC] -specialIntruderRules = - [ kuRule CoerceRule [kdFact x_var] (x_var) - , kuRule PubConstrRule [] (x_pub_var) - , kuRule FreshConstrRule [Fact FreshFact [x_fresh_var]] (x_fresh_var) - , Rule ISendRule [kuFact x_var] [Fact InFact [x_var]] [kLogFact x_var] - , Rule IRecvRule [Fact OutFact [x_var]] [Fact KDFact [x_var]] [] - ] - where - kuRule name prems t = Rule name prems [kuFact t] [kuFact t] - - x_var = varTerm (LVar "x" LSortMsg 0) - x_pub_var = varTerm (LVar "x" LSortPub 0) - x_fresh_var = varTerm (LVar "x" LSortFresh 0) - - ------------------------------------------------------------------------------- --- Subterm Intruder theory ------------------------------------------------------------------------------- - --- | @destuctionRules st@ returns the destruction rules for the given --- subterm rule @st@ -destructionRules :: StRule -> [IntrRuleAC] -destructionRules (StRule lhs@(viewTerm -> FApp (NonAC (f,_)) _) (RhsPosition pos)) = - go [] lhs pos - where - rhs = lhs `atPos` pos - go _ _ [] = [] - -- term already in premises - 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 ] - t' = as!!i - irule = if (t' /= rhs && rhs `notElem` uprems') - then [ Rule (DestrRule f) - ((kdFact t'):(map kuFact uprems')) - [kdFact rhs] [] ] - else [] - go _ (viewTerm -> Lit _) (_:_) = - error "IntruderRules.destructionRules: impossible, position invalid" - -destructionRules _ = [] - --- | Simple removal of subsumed rules for auto-generated subterm intruder rules. -minimizeIntruderRules :: [IntrRuleAC] -> [IntrRuleAC] -minimizeIntruderRules rules = - go [] rules - where - go checked [] = reverse checked - go checked (r@(Rule _ prems concs _):unchecked) = go checked' unchecked - where - checked' = if any (\(Rule _ prems' concs' _) - -> concs' == concs && prems' `subsetOf` prems) - (checked++unchecked) - then checked - else r:checked - --- | @subtermIntruderRules maudeSig@ returns the set of intruder rules for --- the subterm (not Xor, DH, and MSet) part of the given signature. -subtermIntruderRules :: MaudeSig -> [IntrRuleAC] -subtermIntruderRules maudeSig = - minimizeIntruderRules $ concatMap destructionRules (S.toList $ stRules maudeSig) - ++ constructionRules (functionSymbols maudeSig) - --- | @constructionRules fSig@ returns the construction rules for the given --- function signature @fSig@ -constructionRules :: FunSig -> [IntrRuleAC] -constructionRules fSig = - [ createRule s k | (s,k) <- S.toList fSig ] - where - createRule s k = Rule (ConstrRule s) (map kuFact vars) [concfact] [concfact] - where vars = take k [ varTerm (LVar "x" LSortMsg i) | i<- [0..] ] - m = fApp (NonAC (s,k)) vars - concfact = kuFact m - - ------------------------------------------------------------------------------- --- Diffie-Hellman Intruder Rules ------------------------------------------------------------------------------- - --- | @dhIntruderRules@ computes the intruder rules for DH -dhIntruderRules :: WithMaude [IntrRuleAC] -dhIntruderRules = reader $ \hnd -> minimizeIntruderRules $ - [ expRule ConstrRule kuFact return - , invRule ConstrRule kuFact return - ] ++ - concatMap (variantsIntruder hnd) - [ expRule DestrRule kdFact (const []) - , invRule DestrRule kdFact (const []) - ] - where - x_var_0 = varTerm (LVar "x" LSortMsg 0) - x_var_1 = varTerm (LVar "x" LSortMsg 1) - - expRule mkInfo kudFact mkAction = - Rule (mkInfo expSymString) [bfact, efact] [concfact] (mkAction concfact) - where - bfact = kudFact x_var_0 - efact = kuFact x_var_1 - conc = fAppExp (x_var_0, x_var_1) - concfact = kudFact conc - - invRule mkInfo kudFact mkAction = - Rule (mkInfo invSymString) [bfact] [concfact] (mkAction concfact) - where - bfact = kudFact x_var_0 - conc = fAppInv x_var_0 - concfact = kudFact conc - - --- | @variantsIntruder mh irule@ computes the deconstruction-variants --- of a given intruder rule @irule@ -variantsIntruder :: MaudeHandle -> IntrRuleAC -> [IntrRuleAC] -variantsIntruder hnd ru = do - let ruleTerms = concatMap factTerms - (get rPrems ru++get rConcs ru++get rActs ru) - fsigma <- computeVariants (fAppList ruleTerms) `runReader` hnd - let sigma = freshToFree fsigma `evalFreshAvoiding` ruleTerms - 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 - (get rConcs ruvariant) \\ (get rPrems ruvariant) /= [] - -- The conclusion is included in the premises - ) - - case concatMap factTerms $ get rConcs ruvariant of - [viewTerm -> FApp (AC Mult) _] -> - fail "Rules with product conclusion are redundant" - _ -> return ruvariant - --- | @normRule irule@ computes the normal form of @irule@ -normRule' :: IntrRuleAC -> WithMaude IntrRuleAC -normRule' (Rule i ps cs as) = reader $ \hnd -> - let normFactTerms = map (fmap (\t -> norm' t `runReader` hnd)) in - Rule i (normFactTerms ps) (normFactTerms cs) (normFactTerms as) diff --git a/src/Theory/Tools/LoopBreakers.hs b/src/Theory/Tools/LoopBreakers.hs deleted file mode 100644 --- a/src/Theory/Tools/LoopBreakers.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | --- Copyright : (c) 2012 Simon Meier --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : portable --- --- Computate the loop-breakers in the premise-conclusion graph of a set of --- multiset rewriting rules. -module Theory.Tools.LoopBreakers ( - - -- * 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.Model - - --- | 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/Tools/RuleVariants.hs b/src/Theory/Tools/RuleVariants.hs deleted file mode 100644 --- a/src/Theory/Tools/RuleVariants.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Benedikt Schmidt --- Portability : GHC only --- --- Variants of protocol rules. -module Theory.Tools.RuleVariants where - -import Term.Narrowing.Variants -import Term.Rewriting.Norm -import Theory.Model -import Theory.Tools.EquationStore - -import Extension.Prelude -import Logic.Connectives - -import Control.Applicative -import Control.Monad.Bind -import Control.Monad.Reader -import qualified Control.Monad.Trans.PreciseFresh as Precise - -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Traversable (traverse) - -import Debug.Trace.Ignore - --- Variants of protocol rules ----------------------------------------------------------------------- - --- | Compute the variants of a protocol rule. --- 1. Abstract away terms in facts with variables. --- 2. Compute variants of RHSs of equations. --- 3. Apply variant substitutions to equations --- to obtain DNF of equations. --- 4. Simplify rule. -variantsProtoRule :: MaudeHandle -> ProtoRuleE -> ProtoRuleAC -variantsProtoRule hnd ru@(Rule ri prems0 concs0 acts0) = - -- rename rule to decrease variable indices - (`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 (fAppList abstractedTerms) `runReader` hnd - substs = [ restrictVFresh (frees abstrPsCsAs) $ - removeRenamings $ ((`runReader` hnd) . normSubstVFresh') $ - composeVFresh vsubst abstractionSubst - | vsubst <- variantSubsts ] - - case substs of - [] -> error $ "variantsProtoRule: rule has no variants `"++show ru++"'" - _ -> do - -- x <- return (emptySubst, Just substs) -- - x <- simpDisjunction hnd (const False) (Disj substs) - case trace (show ("SIMP",abstractedTerms, - "abstr", abstrPsCsAs, - "substs", substs, - "simpSubsts:", x)) x of - -- the variants can be simplified to a single case - (commonSubst, Nothing) -> - return $ makeRule abstrPsCsAs commonSubst trueDisj - (commonSubst, Just freshSubsts) -> - return $ makeRule abstrPsCsAs commonSubst freshSubsts - - abstrRule = (`runBindT` noBindings) $ do - -- first import all vars into binding to obtain nicer names - mapM_ abstrTerm [ varTerm v | v <- frees (prems0, concs0, acts0) ] - (,,) <$> mapM abstrFact prems0 - <*> mapM abstrFact concs0 - <*> mapM abstrFact acts0 - - irreducible = irreducibleFunctionSymbols (mhMaudeSig hnd) - abstrFact = traverse abstrTerm - 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 - where prems = apply subst ps - concs = apply subst cs - acts = apply subst as - freshSubsts = map (restrictVFresh (frees (prems, concs, acts))) freshSubsts0 - - trueDisj = [ emptySubstVFresh ] diff --git a/src/Theory/Tools/Wellformedness.hs b/src/Theory/Tools/Wellformedness.hs deleted file mode 100644 --- a/src/Theory/Tools/Wellformedness.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} --- | --- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt --- License : GPL v3 (see LICENSE) --- --- Maintainer : Simon Meier --- Portability : GHC only --- --- Wellformedness checks for intruder variants, protocol rules, and --- properties. --- --- The following checks are/should be performed --- (FIXME: compare the list below to what is really implemented.) --- --- [protocol rules] --- --- 1. no fresh names in rule. (protocol cond. 1) --- ==> freshNamesReport --- --- 2. no Out or K facts in premises. (protocol cond. 2) --- ==> factReports --- --- 3. no Fr, In, or K facts in conclusions. (protocol cond. 3) --- ==> factReports --- --- 4. vars(rhs) subset of vars(lhs) u V_Pub --- ==> multRestrictedReport --- --- 5. lhs does not contain reducible function symbols (*-restricted (a)) --- ==> multRestrictedReport --- --- 6. rhs does not contain * (*-restricted (b)) --- ==> multRestrictedReport --- --- 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] --- --- 1. all facts occur with the same arity in the action of some --- protocol rule. --- --- 2. no node variable is used in a message position and vice versa. --- --- -module Theory.Tools.Wellformedness ( - - -- * Wellformedness checking - WfErrorReport - , checkWellformedness - , noteWellformedness - - , prettyWfErrorReport - ) where - -import Prelude hiding (id, (.)) - -import Control.Basics -import Control.Category -import Data.Char -import Data.Generics.Uniplate.Data (universeBi) -import Data.Label -import Data.List -import Data.Maybe -import Data.Monoid (mappend, mempty) -import qualified Data.Set as S -import Data.Traversable (traverse) - -import Control.Monad.Bind - -import Extension.Prelude -import Term.LTerm -import Term.Maude.Signature -import Theory -import Theory.Text.Pretty - ------------------------------------------------------------------------------- --- Types for error reports ------------------------------------------------------------------------------- - -type Topic = String -type WfError = (Topic, Doc) -type WfErrorReport = [WfError] - -prettyWfErrorReport :: WfErrorReport -> Doc -prettyWfErrorReport = - vcat . intersperse (text "") . map ppTopic . groupOn fst - where - ppTopic [] = error "prettyWfErrorReport: groupOn returned empty list" - ppTopic errs@((topic,_):_) = - text topic <> colon $-$ - (nest 2 . vcat . intersperse (text "") $ map snd errs) - - ------------------------------------------------------------------------------- --- Utilities ------------------------------------------------------------------------------- - --- | All protocol rules of a theory. --- thyProtoRules :: OpenTheory -> -thyProtoRules :: OpenTheory -> [ProtoRuleE] -thyProtoRules thy = [ ru | RuleItem ru <- get thyItems thy ] - --- | Lower-case a string. -lowerCase :: String -> String -lowerCase = map toLower - --- | 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 - --- | Clashes -clashesOn :: (Ord b, Ord c) - => (a -> b) -- ^ This projection - -> (a -> c) -- ^ must determine this projection. - -> [a] -> [[a]] -clashesOn f g xs = do - grp <- groupOn f $ sortOn f xs - guard (length (sortednubOn g grp) >= 2) - return grp - --- | Nice quoting. -quote :: String -> String -quote cs = '`' : cs ++ "'" - ------------------------------------------------------------------------------- --- Checks ------------------------------------------------------------------------------- - ---- | Check that the protocol rules are well-formed. -sortsClashCheck :: HasFrees t => String -> t -> WfErrorReport -sortsClashCheck info t = case clashesOn removeSort id $ frees t of - [] -> [] - cs -> return $ - ( "sorts" - , text info $-$ (nest 2 $ numbered' $ map prettyVarList cs) - ) - where - removeSort lv = (lowerCase (lvarName lv), lvarIdx lv) - --- | Report on sort clashes. -ruleSortsReport :: OpenTheory -> WfErrorReport -ruleSortsReport thy = do - ru <- thyProtoRules thy - sortsClashCheck ("rule " ++ quote (showRuleCaseName ru) ++ - " clashing sorts, casings, or multiplicities:") ru - --- | Report on fresh names. -freshNamesReport :: OpenTheory -> WfErrorReport -freshNamesReport thy = do - ru <- thyProtoRules thy - case filter ((LSortFresh ==) . sortOfName) $ universeBi ru of - [] -> [] - names -> return $ (,) "fresh names" $ fsep $ - text ( "rule " ++ quote (showRuleCaseName ru) ++ ": " ++ - "fresh names are not allowed in rule:" ) - : punctuate comma (map (nest 2 . text . show) names) - --- | Report on capitalization of public names. -publicNamesReport :: OpenTheory -> WfErrorReport -publicNamesReport thy = - case findClashes publicNames of - [] -> [] - clashes -> return $ (,) topic $ numbered' $ - map (nest 2 . fsep . punctuate comma . map ppRuleAndName) clashes - where - topic = "public names with mismatching capitalization" - publicNames = do - ru <- thyProtoRules thy - (,) (showRuleCaseName ru) <$> - (filter ((LSortPub ==) . sortOfName) $ universeBi ru) - findClashes = clashesOn (map toLower . show . snd) (show . snd) - ppRuleAndName (ruName, pub) = - text $ "rule " ++ show ruName ++ " name " ++ show pub - --- | Check whether a rule has unbound variables. -unboundCheck :: HasFrees i => String -> Rule i -> WfErrorReport -unboundCheck info ru - | null unboundVars = [] - | otherwise = return $ - ( "unbound" - , text info $-$ (nest 2 $ prettyVarList unboundVars) ) - where - boundVars = S.fromList $ frees (get rPrems ru) - unboundVars = do - v <- frees (get rConcs ru, get rActs ru, get rInfo ru) - guard $ not (lvarSort v == LSortPub || v `S.member` boundVars) - return v - --- | Report on sort clashes. -unboundReport :: OpenTheory -> WfErrorReport -unboundReport thy = do - RuleItem ru <- get thyItems thy - unboundCheck ("rule " ++ quote (showRuleCaseName ru) ++ - " has unbound variables: " - ) ru - --- | Report on facts usage. -factReports :: OpenTheory -> WfErrorReport -factReports thy = concat - [ reservedReport, freshFactArguments, specialFactsUsage - , factUsage, inexistentActions - ] - where - ruleFacts ru = - ( "rule " ++ quote (showRuleCaseName ru) - , extFactInfo <$> concatMap (`get` ru) [rPrems, rActs, rConcs]) - - -- NOTE: The check that the number of actual function arguments in a term - -- agrees with the arity of the function as given by the signature is - -- enforced by the parser and implicitly checked in 'factArity'. - - theoryFacts = -- sortednubOn (fst &&& (snd . snd)) $ - do ruleFacts <$> get thyCache thy - <|> do RuleItem ru <- get thyItems thy - return $ ruleFacts ru - <|> do LemmaItem l <- get thyItems thy - return $ (,) ("lemma " ++ quote (get lName l)) $ do - fa <- formulaFacts (get lFormula l) - return $ (text (show fa), factInfo fa) - - -- we must compute all important information up-front in order to - -- mangle facts with terms with bound variables and such without them - extFactInfo fa = (prettyLNFact fa, factInfo fa) - - factInfo :: Fact t -> (FactTag, Int, Multiplicity) - factInfo fa = (factTag fa, factArity fa, factMultiplicity fa) - - --- Check for usage of protocol facts with reserved names - reservedReport = do - (origin, fas) <- theoryFacts - case mapMaybe reservedFactName fas of - [] -> [] - errs -> return $ (,) "reseved names" $ foldr1 ($--$) $ - wrappedText ("The " ++ origin ++ - " contains facts with reserved names:") - : map (nest 2) errs - - reservedFactName (ppFa, info@(ProtoFact _ name _, _,_)) - | map toLower name `elem` ["fr","ku","kd","out","in"] = - return $ ppFa $-$ text ("show:" ++ show info) - reservedFactName _ = Nothing - - freshFactArguments = do - ru <- thyProtoRules thy - fa@(Fact FreshFact [m]) <- get rPrems ru - guard (not (isMsgVar m || isFreshVar m)) - return $ (,) "Fr facts must only use a fresh- or a msg-variable" $ - text ("rule " ++ quote (showRuleCaseName ru)) <-> - text "fact:" <-> prettyLNFact fa - - -- Check for the usage of special facts at wrong positions - specialFactsUsage = do - ru <- thyProtoRules thy - let lhs = [ fa | fa <- get rPrems ru - , factTag fa `elem` [KUFact, KDFact, OutFact] ] - rhs = [ fa | fa <- get rConcs ru - , factTag fa `elem` [FreshFact, KUFact, KDFact, InFact] ] - check _ [] = mzero - check msg fas = return $ (,) "special fact usage" $ - text ("rule " ++ quote (showRuleCaseName ru)) <-> text msg $-$ - (nest 2 $ fsep $ punctuate comma $ map prettyLNFact fas) - - msum [ check "uses disallowed facts on left-hand-side:" lhs - , check "uses disallowed facts on right-hand-side:" rhs ] - - -- Check for facts with equal name modulo capitalization, but different - -- multiplicity or arity. - factUsage = do - clash <- clashesOn factIdentifier (snd . snd) theoryFacts' - return $ (,) "fact usage" $ numbered' $ do - (origin, (ppFa, info@(tag, _, _))) <- clash - return $ text (origin ++ - ", fact " ++ show (map toLower $ factTagName tag) ++ - ": " ++ showInfo info) - $-$ nest 2 ppFa - where - showInfo (tag, k, multipl) = show $ (showFactTag tag, k, multipl) - theoryFacts' = [ (ru, fa) | (ru, fas) <- theoryFacts, fa <- fas ] - factIdentifier (_, (_, (tag, _, _))) = map toLower $ factTagName tag - - - -- 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 $ map factInfo $ - kLogFact undefined - : dedLogFact undefined - : kuFact undefined - : (do RuleItem ru <- get thyItems thy; get rActs ru) - - inexistentActions = do - LemmaItem l <- get thyItems thy - fa <- sortednub $ formulaFacts (get lFormula l) - let info = factInfo fa - name = get lName l - if info `S.member` ruleActions - then [] - else return $ (,) "lemma actions" $ - text ("lemma " ++ quote name ++ " references action ") $-$ - nest 2 (text $ show info) $-$ - text "but no rule has such an action." - - --- | Gather all facts referenced in a formula. -formulaFacts :: Formula s c v -> [Fact (VTerm c (BVar v))] -formulaFacts = - foldFormula atomFacts - (const mempty) - id - (const mappend) (const $ const id) - where - atomFacts (Action _ fa) = [fa] - atomFacts (EqE _ _) = mempty - atomFacts (Less _ _) = mempty - atomFacts (Last _) = mempty - --- | Gather all terms referenced in a formula. -formulaTerms :: Formula s c v -> [VTerm c (BVar v)] -formulaTerms = - foldFormula atomTerms (const mempty) id (const mappend) (const $ const id) - where - atomTerms (Action i fa) = i : factTerms fa - atomTerms (EqE t s) = [t, s] - atomTerms (Less i j) = [i, j] - atomTerms (Last i) = [i] - --- TODO: Perhaps a lot of errors would be captured when making the signature --- of facts, term, and atom constructors explicit. -lemmaAttributeReport :: OpenTheory -> WfErrorReport -lemmaAttributeReport thy = do - lem <- theoryLemmas thy - guard $ get lTraceQuantifier lem == ExistsTrace - && ReuseLemma `elem` get lAttributes lem - return ( "attributes" - , text "lemma" <-> (text $ quote $ get lName lem) <> colon <-> - text "cannot reuse 'exists-trace' lemmas" - ) - --- | Check for mistakes in lemmas. --- --- TODO: Perhaps a lot of errors would be captured when making the signature --- of facts, term, and atom constructors explicit. -formulaReports :: OpenTheory -> WfErrorReport -formulaReports thy = do - (header, fm) <- annFormulas - msum [ ((,) "quantifier sorts") <$> checkQuantifiers header fm - , ((,) "formula terms") <$> checkTerms header fm - , ((,) "guardedness") <$> checkGuarded header fm - ] - where - annFormulas = do LemmaItem l <- get thyItems thy - let header = "lemma " ++ quote (get lName l) - fm = get lFormula l - return (header, fm) - <|> do AxiomItem ax <- get thyItems thy - let header = "axiom " ++ quote (get axName ax) - fm = get axFormula ax - return (header, fm) - - -- check that only message and node variables are used - checkQuantifiers header fm - | null disallowed = [] - | otherwise = return $ fsep $ - (text $ header ++ "uses quantifiers with wrong sort:") : - (punctuate comma $ map (nest 2 . text . show) disallowed) - where - binders = foldFormula (const mempty) (const mempty) id (const mappend) - (\_ binder rest -> binder : rest) fm - disallowed = filter (not . (`elem` [LSortMsg, LSortNode]) . snd) binders - - -- check that only bound variables and public names are used - checkTerms header fm - | null offenders = [] - | otherwise = return $ - (fsep $ - (text $ header ++ " uses terms of the wrong form:") : - (punctuate comma $ map (nest 2 . text . quote . show) offenders) - ) $--$ - wrappedText - "The only allowed terms are public names and bound node and message\ - \ variables. If you encounter free message variables, then you might\ - \ have forgotten a #-prefix. Sort prefixes can only be dropped where\ - \ this is unambiguous." - where - offenders = filter (not . allowed) $ formulaTerms fm - 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 formulaToGuarded fm of - Left err -> return $ - text (header ++ " cannot be converted to a guarded formula:") $-$ - nest 2 err - Right _ -> [] - - - - --- | 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 - - ------------------------------------------------------------------------------- --- Theory ------------------------------------------------------------------------------- - - - --- | Returns a list of errors, if there are any. -checkWellformedness :: OpenTheory - -> WfErrorReport -checkWellformedness thy = concatMap ($ thy) - [ unboundReport - , freshNamesReport - , publicNamesReport - , ruleSortsReport - , factReports - , formulaReports - , lemmaAttributeReport - , multRestrictedReport - ] - --- | Adds a note to the end of the theory, if it is not well-formed. -noteWellformedness :: WfErrorReport -> OpenTheory -> OpenTheory -noteWellformedness report thy = - addComment wfErrorReport thy - where - wfErrorReport - | null report = text "All well-formedness checks were successful." - | otherwise = vsep - [ text "WARNING: the following wellformedness checks failed!" - , prettyWfErrorReport report - ] - diff --git a/src/Web/Dispatch.hs b/src/Web/Dispatch.hs --- a/src/Web/Dispatch.hs +++ b/src/Web/Dispatch.hs @@ -138,18 +138,11 @@ -> AutoProver -> IO TheoryMap loadTheories readyMsg thDir thLoader autoProver = do - mkImageDir thPaths <- filter (".spthy" `isSuffixOf`) <$> getDirectoryContents thDir theories <- catMaybes <$> mapM loadThy (zip [1..] (map (thDir ) thPaths)) putStrLn readyMsg return $ M.fromList theories where - -- Create image directory - mkImageDir = do - let dir = thDir imageDir - existsDir <- doesDirectoryExist dir - unless existsDir (createDirectory dir) - -- Load theories loadThy (idx, path) = E.handle catchEx $ do thy <- thLoader path diff --git a/src/Web/Hamlet.hs b/src/Web/Hamlet.hs --- a/src/Web/Hamlet.hs +++ b/src/Web/Hamlet.hs @@ -32,7 +32,7 @@ import Data.Ord import Data.Time.Format import Data.Version (showVersion) -import Text.Blaze.Html5 (preEscapedString) +import Text.Blaze.Html (preEscapedToMarkup) import System.Locale @@ -60,6 +60,7 @@ -> Widget -- rootTpl theories form enctype nonce = [whamlet| rootTpl theories = [whamlet| + $newline never
@@ -88,6 +89,7 @@ -- | Template for listing theories. theoriesTpl :: TheoryMap -> Widget theoriesTpl thmap = [whamlet| + $newline never $if M.null thmap No theories loaded! $else @@ -118,6 +120,7 @@ -- | Template for single line in table on root page. theoryTpl :: (TheoryIdx, TheoryInfo) -> Widget theoryTpl th = [whamlet| + $newline never @@ -139,6 +142,7 @@ -- threadsTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => [T.Text] -> h {- threadsTpl threads = [whamlet| + $newline never

Threads

This page lists all threads that are currently registered as @@ -161,6 +165,7 @@ -- | Template for header frame (various information) headerTpl :: TheoryInfo -> Widget headerTpl info = [whamlet| + $newline never

Running @@ -200,7 +205,9 @@ proofStateTpl :: RenderUrl -> TheoryInfo -> IO Widget proofStateTpl renderUrl ti = do let res = renderHtmlDoc $ theoryIndex renderUrl (tiIndex ti) (tiTheory ti) - return [whamlet| #{preEscapedString res} |] + return [whamlet| + $newline never + #{preEscapedToMarkup res} |] -- | Framing/UI-layout template (based on JavaScript/JQuery) overviewTpl :: RenderUrl @@ -211,6 +218,7 @@ proofState <- proofStateTpl renderUrl info mainView <- pathTpl renderUrl info path return [whamlet| + $newline never
^{headerTpl info}
@@ -235,11 +243,14 @@ -> TheoryPath -- ^ Path to display on load -> IO Widget pathTpl renderUrl info path = - return $ [whamlet| #{htmlThyPath renderUrl info path} |] + return $ [whamlet| + $newline never + #{htmlThyPath renderUrl info path} |] -- | Template for introduction. introTpl :: Widget introTpl = [whamlet| + $newline never