tamarin-prover 0.1.1.0 → 0.4.0.0
raw patch · 97 files changed
+7235/−5339 lines, 97 filesdep +HUnitdep +blaze-htmldep +lifted-basedep −data-defaultdep −template-haskelldep −wai-extradep ~aesondep ~arraydep ~cmdargssetup-changedbinary-added
Dependencies added: HUnit, blaze-html, lifted-base
Dependencies removed: data-default, template-haskell, wai-extra, yesod-form
Dependency ranges changed: aeson, array, cmdargs, containers, deepseq, fclabels, filepath, hamlet, monad-control, process, tamarin-prover-term, tamarin-prover-utils, time, wai, warp, yesod-core, yesod-json, yesod-static
Files
- CHANGES +0/−6
- README +0/−127
- Setup.hs +91/−0
- data/AUTHORS +2/−2
- data/CHANGES +27/−0
- data/css/tamarin-prover-ui.css +151/−57
- data/doc/MANUAL +336/−0
- data/etc/spthy.vim +3/−1
- data/examples/TLS.spthy +0/−190
- data/examples/UserGuide.spthy +0/−437
- data/examples/csf12/Artificial.spthy +10/−9
- data/examples/csf12/DH2_original.spthy +144/−0
- data/examples/csf12/JKL_TS1_2004-KI.spthy +0/−116
- data/examples/csf12/JKL_TS1_2004_KI.spthy +126/−0
- data/examples/csf12/JKL_TS1_2008-KI.spthy +0/−120
- data/examples/csf12/JKL_TS1_2008-KI_wPFS.spthy +0/−139
- data/examples/csf12/JKL_TS1_2008_KI.spthy +120/−0
- data/examples/csf12/JKL_TS2_2004-KI.spthy +0/−117
- data/examples/csf12/JKL_TS2_2004-KI_wPFS.spthy +0/−135
- data/examples/csf12/JKL_TS2_2004_KI_wPFS.spthy +135/−0
- data/examples/csf12/JKL_TS2_2008-KI.spthy +0/−120
- data/examples/csf12/JKL_TS2_2008-KI_wPFS.spthy +0/−139
- data/examples/csf12/JKL_TS2_2008_KI_wPFS.spthy +139/−0
- data/examples/csf12/JKL_TS3_2004-KI_wPFS.spthy-nonterm +0/−199
- data/examples/csf12/JKL_TS3_2004_KI_wPFS.spthy_nonterm +199/−0
- data/examples/csf12/JKL_TS3_2008-KI_wPFS.spthy-nonterm +0/−188
- data/examples/csf12/JKL_TS3_2008_KI_wPFS.spthy_nonterm +188/−0
- data/examples/csf12/KAS1.spthy +129/−0
- data/examples/csf12/KAS2_eCK.spthy +128/−0
- data/examples/csf12/KAS2_original.spthy +131/−0
- data/examples/csf12/KEA_plus_KI_KCI.spthy +27/−18
- data/examples/csf12/KEA_plus_KI_KCI_wPFS.spthy +23/−16
- data/examples/csf12/KEA_plus_eCK.spthy +2/−2
- data/examples/csf12/NAXOS_eCK.spthy +104/−107
- data/examples/csf12/NAXOS_eCK_PFS.spthy +105/−105
- data/examples/csf12/STS-MAC-fix1.spthy +0/−123
- data/examples/csf12/STS-MAC-fix2.spthy +0/−122
- data/examples/csf12/STS-MAC.spthy +0/−122
- data/examples/csf12/STS_MAC.spthy +129/−0
- data/examples/csf12/STS_MAC_fix1.spthy +132/−0
- data/examples/csf12/STS_MAC_fix2.spthy +129/−0
- data/examples/csf12/SignedDH_PFS.spthy +2/−2
- data/examples/csf12/SignedDH_eCK.spthy +1/−1
- data/examples/csf12/UM_PFS.spthy +1/−1
- data/examples/csf12/UM_eCK.spthy +1/−1
- data/examples/csf12/UM_eCK_noKCI.spthy +1/−1
- data/examples/csf12/UM_wPFS.spthy +1/−1
- data/examples/stable/InvariantsExample.spthy +69/−0
- data/examples/stable/TLS.spthy +188/−0
- data/examples/stable/Tutorial.spthy +403/−0
- data/img/favicon.ico binary
- data/img/tamarin-logo-128.png binary
- data/img/tamarin-logo-3-0-0.png binary
- data/img/tamarin-logo-3-1-0.png binary
- data/img/tamarin-logo-32.png binary
- data/img/tamarin-logo-64.png binary
- data/img/tamarin-logo-96.png binary
- data/intruder_variants_dh.spthy +254/−268
- data/js/tamarin-prover-ui.js +83/−87
- interactive-only-src/Paths_tamarin_prover.hs +1/−1
- src/Main.hs +9/−712
- src/Main/Console.hs +248/−0
- src/Main/Environment.hs +157/−0
- src/Main/Mode/Batch.hs +175/−0
- src/Main/Mode/Interactive.hs +112/−0
- src/Main/Mode/Intruder.hs +70/−0
- src/Main/Mode/Test.hs +70/−0
- src/Main/TheoryLoader.hs +190/−0
- src/Main/Utils.hs +28/−0
- src/Main_Full.hs +18/−0
- src/Main_NoGui.hs +17/−0
- src/Theory.hs +200/−93
- src/Theory/AbstractInterpretation.hs +136/−0
- src/Theory/Atom.hs +12/−9
- src/Theory/Fact.hs +42/−16
- src/Theory/Formula.hs +29/−16
- src/Theory/IntruderRules.hs +77/−59
- src/Theory/Parser.hs +98/−67
- src/Theory/Proof.hs +64/−29
- src/Theory/Proof/CaseDistinctions.hs +101/−139
- src/Theory/Proof/EquationStore.hs +164/−178
- src/Theory/Proof/Guarded.hs +35/−31
- src/Theory/Proof/Sequent.hs +158/−87
- src/Theory/Proof/Sequent/Dot.hs +125/−63
- src/Theory/Proof/SolveGuarded.hs +24/−21
- src/Theory/Proof/Types.hs +143/−128
- src/Theory/Rule.hs +150/−56
- src/Theory/RuleSet.hs +79/−0
- src/Theory/RuleVariants.hs +17/−8
- src/Theory/Signature.hs +2/−2
- src/Theory/Wellformedness.hs +116/−23
- src/Web/Dispatch.hs +13/−11
- src/Web/Hamlet.hs +162/−125
- src/Web/Handler.hs +153/−132
- src/Web/Theory.hs +181/−127
- src/Web/Types.hs +49/−57
- tamarin-prover.cabal +96/−70
− CHANGES
@@ -1,6 +0,0 @@-* 0.1.1.0 Bug-fix release- - - fixed: automatically create output directory, if it does not exist- - fixed: wrong flags given in help message for starting interactive mode--* 0.1.0.0 First public release
− README
@@ -1,127 +0,0 @@-======================================================================-README for the tamarin-prover for security protocol verification-======================================================================--Author: Simon Meier <simon.meier@inf.ethz.ch>--Creation Date: 8/02/2012---1. Introduction-===============-- The tool is written in Haskell and provides two usage modes as described- below.--- NOTE TO REVIEWERS: - to reproduce our results from the paper install the tool and run-- make case-studies-- in the root directory of this source distribution. This will create- a directory './case-studies' with the analyzed files and their proofs and- attacks.----2. Installation instructions-============================--2.1 Requirements------------------- The tool was tested on Linux and Mac OsX. It relies on - - - maude version 2.6 for AC unification - - download and install "Full Maude 2.6" from http://maude.cs.uiuc.edu/download/-- - the 'dot' tool from GraphViz for rendering proof states as graphs-- download and install from http://www.graphviz.org/- (most Linux distributions have a corresponding package)- - - GHC 7.0.4 and cabal-install-- included in the Haskell Platform 2011.2.0.1- available from http://hackage.haskell.org/platform/---2.1 Installing tamarin-prover------------------------------- You need a working Haskell environment that provides GHC 7 and the 'cabal- install' tool. The simplest way to get such an environment is to download and- install the Haskell Platform package for your OS. - - http://hackage.haskell.org/platform/- - Then call-- cabal install-- in the root directory of this source code package. This will use the- Haskell's deployment tool 'cabal-install' to download all missing libraries- from Hackage, the central Haskell library repository and install the- 'tamarin-prover' executable in the default installation location of- cabal-install. The installation location is printed at the end of the build- process. Note that this may take a long time due to the large number of- dependencies of the built-in webserver used to serve the interactive mode.---3. Usage-========--the tamarin-prover can be used in two modes: -- (1) a batch mode where it just tries to parse the given file (and if called- with --prove) to prove their specified lemmas.-- (2) an interactive mode, which runs a webserver that allows to construct- and explore security proofs interactively.- This mode has to be run with an argument that specifies directory- containing the protocol models to be investigated. --See the help message output when calling 'tamarin-prover' without any flags-for more information.----4. Built-in Equational theories-===============================--There are several built-in equational theories which can be activated-for a given theory file by including:--> builtin: theoryname--The following theories are supported as builtins:--diffie-hellman:- functions: _ ^ _, inv(_), _*_- equations: see paper--hashing:- functions: h(_)- no equations--signing:- functions: sign(_,_), verify(_,_,_), pk(_), true- equations: verify(sign(m,sk), m, pk(sk)) = true--symmetric-encryption:- functions: senc(_,_), sdec(_,_)- equations: sdec(senc(m,k),k) = m--asymmetric-encryption:- functions: aenc(_,_), adec(_,_), pk(_)- equations: adec(aenc(m, pk(sk)), sk) = m---***-* Happy Proving :-)-*-* In case of questions do not hesistate to contact the authors-* simon.meier@inf.ethz.ch or benedikt.schmidt@inf.ethz.ch-***
Setup.hs view
@@ -1,2 +1,93 @@ import Distribution.Simple main = defaultMain++{- Inferring the package version from git. Posted by https://github.com/hvr+ -+ - https://gist.github.com/656738++import Control.Exception+import Control.Monad+import Data.Maybe+import Data.Version+import Distribution.PackageDescription (PackageDescription(..), HookedBuildInfo, GenericPackageDescription(..))+import Distribution.Package (PackageIdentifier(..))+import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, UserHooks(..))+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.Setup (BuildFlags(..), ConfigFlags(..))+import Distribution.Simple.Utils (die)+import System.Process (readProcess)+import Text.ParserCombinators.ReadP (readP_to_S)++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { confHook = myConfHook+ , buildHook = myBuildHook+ }++-- configure hook+myConfHook :: (GenericPackageDescription, HookedBuildInfo)+ -> ConfigFlags+ -> IO LocalBuildInfo+myConfHook (gpdesc, hbinfo) cfg = do+ let GenericPackageDescription {+ packageDescription = pdesc@PackageDescription {+ package = pkgIden }} = gpdesc++ gitVersion <- inferVersionFromGit (pkgVersion (package pdesc))++ let gpdesc' = gpdesc {+ packageDescription = pdesc {+ package = pkgIden { pkgVersion = gitVersion } } }++ -- putStrLn $ showVersion gitVersion++ confHook simpleUserHooks (gpdesc', hbinfo) cfg+++-- build hook+myBuildHook :: PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> BuildFlags+ -> IO ()+myBuildHook pdesc lbinfo uhooks bflags = do+ let lastVersion = pkgVersion $ package pdesc++ gitVersion <- inferVersionFromGit lastVersion ++ when (gitVersion /= lastVersion) $+ die("The version reported by git '" ++ showVersion gitVersion +++ "' has changed since last time this package was configured (version was '" +++ showVersion lastVersion ++ "' back then), please re-configure package")++ buildHook simpleUserHooks pdesc lbinfo uhooks bflags++-- |Infer package version from Git tags. Uses `git describe` to infer 'Version'.+inferVersionFromGit :: Version -> IO Version+inferVersionFromGit version0 = do+ ver_line <- init `liftM` readProcess "git"+ [ "describe"+ , "--abbrev=5"+ , "--tags"+ , "--match=v[0-9].[0-9][0-9]"+ , "--dirty"+ , "--long"+ , "--always"+ ] ""++ -- ver_line <- return "v0.1-42-gf9f4eb3-dirty"+ putStrLn ver_line+ -- let versionStr = ver_line -- (head ver_line == 'v') `assert` replaceFirst '-' '.' (tail ver_line)+ -- Just version = listToMaybe [ p | (p, "") <- readP_to_S parseVersion versionStr ]++ return version0++{-+-- | Helper for replacing first occurence of character by another one.+replaceFirst :: Eq a => a -> a -> [a] -> [a]+replaceFirst _ _ [] = []+replaceFirst o r (x:xs) | o == x = r : xs+ | otherwise = x : replaceFirst o r xs+-}++-}
data/AUTHORS view
@@ -3,5 +3,5 @@ Simon Meier <simon.meier@inf.ethz.ch> Contributors:- protocol models: Cas Cremers <cas.cremers@inf.ethz.ch>- web interface: Cedric Staub <cs@cssx.ch+ protocol models, GUI: Cas Cremers <cas.cremers@inf.ethz.ch>+ original web interface: Cedric Staub <cs@cssx.ch
+ data/CHANGES view
@@ -0,0 +1,27 @@+* 0.4.0.0 The version we used for our CSF'12 paper++ - core prover:+ - improved speed of constraint solver+ - improved goal selection heuristic+ - compute better loop-breakers for precomputing case splits+ - experimental support for partial forward evaluation+ - experimental support for loop invariants about construction rules++ - input syntax:+ - allow searching for trace existence using 'exists-trace'+ - allow local let-block in rule definitions++ - GUI:+ - normalize variable indices before display+ - more compact and beautiful default style for graph layout++ - bugfixes: quite a slew, most notably+ - compilation on Windows and GHC 7.4.1+ - intruder rule generation works now correctly again++* 0.1.1.0 Bug-fix release+ + - fixed: automatically create output directory, if it does not exist+ - fixed: wrong flags given in help message for starting interactive mode++* 0.1.0.0 First public release
data/css/tamarin-prover-ui.css view
@@ -10,6 +10,8 @@ sans-serif; /* Fallback */ background: #fff; font-size: 0.95em;+ padding: 0px;+ margin: 0px; } a {@@ -64,12 +66,33 @@ margin: 0.5em; } +div.intropage {+ padding-left: 25px;+ padding-right: 25px;+ padding-top: 10px;+ padding-bottom: 10px;+}+ img.icon { padding: 0; margin: 0; height: 1em; } +/* Messages to the user+ *********************/++div.warning {+ margin: 1em;+ padding: 2em;+ background: #ffdddd;+ border: solid 2px #ff8080;+ font-weight: bold;+ text-align: center;+ font-size: large;+}++ /* Highlighting Styles *********************/ @@ -85,19 +108,36 @@ color: #a00000; } -.hl_solved {+.hl_good { background: #bbeebb; } +.hl_bad {+ background: #eecccc;+}+ .hl_superfluous {- background: #eebbbb;+ color: #ff0000;+ text-decoration: line-through; } .keys { font-weight: bold;- color: #800000;+ font-size: 1.1em;+ color: #003040;+ font-family:+ 'DejaVu Sans Mono', /* Linux */+ 'Liberation Mono', /* Linux/RedHat */+ 'Monaco', /* Mac OS X */+ 'Lucida Consola', /* Windows */+ monospace; /* Fallback */ } +.tamarin {+ font-family: Roman,serif;+ font-variant: small-caps;+}+ /* Specific Styles *****************/ @@ -124,9 +164,16 @@ } img.graph {- border: solid 1px #ccc;+ border: solid 2px #3a6c78; } +div#help {+ border: solid 1px #000000;+ background: #dfeff1;+ padding: 1em;+ margin: 2em;+}+ /* Forms *******/ @@ -199,7 +246,6 @@ background: none; } -span.hl_solved:hover + a.remove-step, a.proof-step:hover + a.remove-step { /* Standard */ opacity: 0.5;@@ -239,30 +285,30 @@ margin-top: 0em; border-radius: 0.3em; padding: 0.3em;- border: solid 1px #aeaeae;+ border: solid 1px #3a6c78; /* Gecko */ background: -moz-linear-gradient( top,- #eeeeee 0%,- #cccccc 100%);+ #dfeff1 0%,+ #7dc0cd 100%); /* Presto */ background: -o-linear-gradient( top,- #eeeeee 0%,- #cccccc 100%);+ #dfeff1 0%,+ #7dc0cd 100%); /* Webkit */ background: -webkit-linear-gradient( top,- #eeeeee 0%,- #cccccc 100%);+ #dfeff1 0%,+ #7dc0cd 100%); /* Trident */ filter: progid:DXImageTransform.Microsoft.gradient(- startColorstr='#eeeeee',- endColorstr='#cccccc',+ startColorstr='#dfeff1',+ endColorstr='#7dc0cd', GradientType=0 ); } @@ -327,43 +373,28 @@ table { border-collapse: collapse;+ border: solid 2px #3a6c78; } table th {+ text-align: left; padding: 0.5em;- background: #eeeeee;- border: solid 1px #aeaeae;- /* Gecko */- background:- -moz-linear-gradient(- top,- #eeeeee 0%,- #cccccc 100%);- /* Presto */- background:- -o-linear-gradient(- top,- #eeeeee 0%,- #cccccc 100%);- /* Webkit */- background:- -webkit-linear-gradient(- top,- #eeeeee 0%,- #cccccc 100%);- /* Trident */- filter:- progid:DXImageTransform.Microsoft.gradient(- startColorstr='#eeeeee',- endColorstr='#cccccc',- GradientType=0 );+ padding-left: 15px;+ padding-right: 15px;+ background: #dfeff1;+ /*+ * border: solid 1px #3a6c78;+ */+ border-bottom: solid 1px #e3fcff; } table td { background: #fff; text-align: left; padding: 0.5em;- border: solid 1px #aeaeae;+ padding-left: 15px;+ padding-right: 15px;+ border: solid 1px #3a6c78; } /* Headings@@ -375,33 +406,37 @@ font-weight: bold; position: relative; margin: 0em;- padding: 0.5em;- background: #eeeeee;- border-bottom: solid 1px #aeaeae;+ padding: 25px;+ padding-top: 0.7em;+ padding-bottom: 0.5em;+ background: #dfeff1;+ border-bottom: solid 1px #eff7f8;+ border-top: solid 1px #3a6c78;+ /* border-top: solid 5px #3a6c78; */ width: 100%; /* Gecko */ background: -moz-linear-gradient( top,- #eeeeee 0%,- #cccccc 100%);+ #3a6c78 0%,+ #dfeff1 20%); /* Presto */ background: -o-linear-gradient( top,- #eeeeee 0%,- #cccccc 100%);+ #3a6c78 0%,+ #dfeff1 20%); /* Webkit */ background: -webkit-linear-gradient( top,- #eeeeee 0%,- #cccccc 100%);+ #3a6c78 0%,+ #dfeff1 20%); /* Trident */ filter: progid:DXImageTransform.Microsoft.gradient(- startColorstr='#eeeeee',- endColorstr='#cccccc',+ startColorstr='#66b9cd',+ endColorstr='#dfeff1', GradientType=0 ); } @@ -456,6 +491,9 @@ #ui-main-display, #ui-debug-display, #proof { z-index: inherit; padding: 0.8em;+ padding-top: 25px;+ padding-left: 25px; /* propagate to ui-layout-pane-north and pane-head */+ padding-right: 25px; /* propagate to ui-layout-pane-north and pane-head */ margin: 0em; height: 90%; }@@ -470,15 +508,42 @@ .ui-layout-pane-north { font-size: 0.8em;- background: #eeeeee;- border-bottom: solid 1px #aeaeae;+ padding-left: 25px;+ padding-right: 25px;+ background: #dfeff1;+ border-bottom: solid 1px #7dc0cd;+ /* Gecko */+ background:+ -moz-linear-gradient(+ top,+ #dfeff1 0%,+ #66b9cd 100%);+ /* Presto */+ background:+ -o-linear-gradient(+ top,+ #dfeff1 0%,+ #66b9cd 100%);+ /* Webkit */+ background:+ -webkit-linear-gradient(+ top,+ #dfeff1 0%,+ #66b9cd 100%);+ /* Trident */+ filter:+ progid:DXImageTransform.Microsoft.gradient(+ startColorstr='#dfeff1',+ endColorstr='#66b9cd',+ GradientType=0 ); } div#header-info { float: left; font-weight: bold;- padding: 0.75em;- border: solid 1px #eeeeee;+ padding-top: 0.85em;+ padding-bottom: 0.85em;+ border: 0px; } div#header-links {@@ -496,7 +561,7 @@ } .ui-layout-resizer {- background-color: #aeaeae;+ background-color: #3a6c78; z-index: 1 !important; } @@ -504,3 +569,32 @@ background-color: #666666; border-radius: 1em; }++/* Logo+ ********/++div#introbar {+ height: 3em;+}++div#logo p {+ height: 124px;+ left: 0px;+ right: 0px;+ background-color: #c3ea71;+ padding: 0px;+ margin: 0px;+/*+ background-image: url('file:///home/cas/src/tamarin-prover/images/tamarin-logo-3-1-0.png');+*/+ background-image: url('/static/img/tamarin-logo-3-1-0.png');+ background-repeat: repeat-x;+}++div#logo img {+ position: relative;+ top: 0px;+ left: 0px;+ display: inline;+}+
+ data/doc/MANUAL view
@@ -0,0 +1,336 @@+User manual for the Tamarin prover+==================================++Date: 2012/04/11+Authors: Simon Meier <iridcode@gmail.com>,+ Benedikt Schmidt <beschmi@gmail.com>+++Installation+============++See http://www.infsec.ethz.ch/research/software#TAMARIN for detailed+installation instructions for Linux and Mac. The Tamarin prover also runs on+Windows. Drop us a mail, if you would like access to a precompiled binary.+++Syntax highlighting+-------------------++We provide syntax highlighting files for the 'vim' text editor. Here, we+describe how to install them. Let DATA_PATH be the parent directory of the+examples directory output in Tamarin's help message. The 'vim' syntax+highlighting files are found at++ DATA_PATH/etc/++To install them, copy 'DATA_PATH/etc/filepath.vim' to the '~/.vim' directory+and copy 'DATA_PATH/etc/spthy.vim' to the '~/.vim/syntax directory'. If one of+these directories does not exist, then just create it.+++Usage+=====++Once you have installed the 'tamarin-prover' executable, calling it without+any arguments will print a help message explaining its different modes and the+paths to example files. We suggest that you first have a look at the+'Tutorial.spthy' file referenced there.++Once, you have done that, you probably want to start modeling your own+protocols. We normally use the following workflow to do that.++ 1. Copy the example protocol that is most similar to the one your are+ modeling. Let us assume that this copy is named 'myproto.spthy'.++ 2. Modify the protocol a bit and call 'tamarin-prover myproto.spthy' to+ ensure that it still parses and all well-formedness checks pass. This+ way you get immediate feedback on your changes. Moreover, you can see the+ expansions of syntactic sugar like the built-in signatures for hashing or+ asymmetric encryption.++ 3. Once you are satisfied with your model, check if the automated prover+ succeeds in analyzing your protocol by calling+ + 'tamarin-prover myproto.spthy --prove'++ 4. If the Tamarin prover does not terminate, then you can either bound the+ proof-depth using the '--bound' flag or you can switch to the interactive+ GUI to analyze what is going wrong. Call++ 'tamarin-prover interactive myproto.spthy'++ and try to construct the proof interactively.++ Note that you can also use the GUI to sanity check your model. Just go+ through the message theory and check that it really models what you+ intent to model. Moreover, the precomputed case distinctions, described+ below, give a good overview about the behaviour/specification of your+ protocol. If something is wrong with your model, then it is likely that+ you can see it already from the precomputed case distinctions.++++Additional Theory+=================++Most of the theory behind the Tamarin prover is described in our CSF 2012+paper, whose extended version is available from++ http://www.infsec.ethz.ch/research/software#TAMARIN++The implementation exploits a slightly refined theory, which allows to store+multiple constraint reduction steps in the form of *precomputed case+distinctions* and which allows to delay the enumeration of the finite variants+of multiset rewriting rules using an *equation store*. We explain these two+components below. We also give a sneak-peek preview on the theory we have+developed for dealing with loop-invariants.+++Precomputed Case Distinctions+-----------------------------++Apart from unification, the most common step performed by Tamarin is the+enumeration of the possible origins of an open premise. Most of these+backwards steps result in a number of trivial further constraint reduction+steps being applied immediately. Instead of applying them over and over during+proof/counter-example construction, we precompute the result of doing one+backwards step and use the resulting precomputed case distinctions during+proof/counter-example search.++This precomputation is sound because the applicability of all our constraint+reduction rules is invariant under set union and instantiation. We precompute+cases for an arbitrary instance of every protocol fact and every outermost+constructor of a message.+++Equation Store+--------------++We store equations in a special form to allow delaying case splits on them.+This allows for example to determine the shape of a signed message without case+splitting on its variants. In the GUI, you can see the equation store being+pretty printed as follows.++ free-substitution++ 1. fresh-substitution-group+ ...+ n. fresh substitution-group++The free-substitution represents the equalities that hold for the free+variables in the constraint system in the usual normal form, i.e., a+substitution. The variants of a protocol rule are represented as a group of+substitutions mapping free variables of the constraint system to terms+containing only fresh variables. The different fresh-substitutions in a group+are interpreted as a disjunction.++Logically, the equation store represents expression of the form++ x_1 = t_free_1+ & ...+ & x_n = t_free_n+ & ( (Ex y_111 ... y_11k. x_111 = t_fresh_111 & ... & x_11m = t_fresh_11m)+ | ...+ | (Ex y_1l1 ... y_1lk. x_1l1 = t_fresh_1l1 & ... & x_1lm = t_fresh_1lm)+ )+ & ..+ & ( (Ex y_o11 ... y_o1k. x_o11 = t_fresh_o11 & ... & x_o1m = t_fresh_o1m)+ | ...+ | (Ex y_ol1 ... y_olk. x_ol1 = t_fresh_ol1 & ... & x_1lm = t_fresh_1lm)+ )+++(Loop) Invariants+-----------------++The normal form conditions that we impose on dependency graphs can be seen as+a strong invariant on security protocol execution. As we have shown in our+case studies many security properties follow from these normal form+conditions. However, for some protocols additional invariants are necessary to+prove their security properties.++We can formalize such invariants by specifying them as trace formulas. We can+prove them using the induction scheme associated to the traces of a protocol.+We using this induction scheme in the form of a trace formula conversion that+converts a guarded trace formula \phi to a semantically equivalent formula+\phi_{inductive}. This formula \phi_{inductive} is again a guarded trace+formula. It is easier to prove because it contains the induction hypothesis in+a weakened form. Semantically, the formula \phi_{inductive} states that we are+looking for counter-examples that are minimal with respect to the prefix-order+on traces.++You can apply induction by clicking on the 'induction' proof method in the+GUI or adding the [inductive] attribute to a lemma. An example protocol whose+proof require induction is given in 'examples/stable/InvariantsExample.spthy'.++++Security Protocol Theories+==========================++A security protocol theory specifies a signature, an equational theory, a+security protocol, and several lemmas, which formalize security properties.+The paper explaining the theory behind Tamarin has been published at CSF 2012+and its extended version is available from++ http://www.infsec.ethz.ch/research/software#TAMARIN++Here, we explain the formal syntax of the security protocol theory format that+is processed by Tamarin. We recommend first reading the 'Tutorial.spthy'+example before delving into the following section.++Comments are C-style: ++ /* for a multi-line comment */+ // for a line-comment++All security protocol theory are named and delimited by 'begin' and 'end'.+We explain the non-terminals of the body in the following paragraphs.++ security_protocol_theory := 'theory' ident 'begin' body 'end'+ body := (signature_spec | rule | lemma | formal_comment)+++Here, we use the term signature more liberally to denote both the defined+function symbols and the equalities describing their interaction. Note that+our parser is stateful and remembers what functions have been defined. It will+only parse function applications of defined functions.++ signature_spec := functions | equations | built_in+ functions := 'functions' ':' (ident '/' arity) list+ equations := 'equations' ':' (term '=' term) list+ arity := digit+++Note that the equations must be subterm-convergent. Tamarin provides built-in+sets of function definitions and subterm convergent equations. They are+expanded upon parsing and you can therefore inspect them by pretty printing+the file using 'tamarin-prover your_file.spthy'. The built-in 'diffie-hellman'+is special. It refers to the equations given in the paper. You need to enable+it to parse terms containing exponentiations, e.g., g ^ x.++ built_in := 'builtins' ':' built_ins list+ built_ins := 'diffie-hellman' + | 'hashing' | 'symmetric-encryption' + | 'asymmetric-encryption' | 'signing' ++Multiset rewriting rules are specified as follows. The protocol corresponding+to a security protocol theory is the set of all multiset rewriting rules+specified in the body of the theory.++ rule := 'rule' ident ':' + [let_block]+ '[' facts ']' ( '-->' | '--[' facts ']->') '[' facts ']'++ let_block := 'let' (ident '=' term)+ 'in'++The let-block allows more succinct specifications. The equations are applied+in a bottom-up fashion. For example,++ let x = y+ y = <z,x>+ in [] --> [ A(y)] is desugared to [] --> [ A(<z,y>) ]++This becomes a lot less confusing if you keep the set of variables on the+left-hand side separate from the free variables on the right-hand side ;-)++Lemmas specify security properties. By default, the given formula is+interpreted as a property that must hold for all traces of the protocol of the+security protocol theory. You can change this using the 'exists-trace' trace+quantifier.++ lemma := 'lemma' ident [lemma_attrs] ':' + [trace_quantifier] + '"' formula '"'+ lemma_attrs := '[' ('typing' | 'reuse' | 'inductive') ']'+ trace_quantifier := 'all-traces' | 'exists-trace'+++Formal comments are used to make the input more readable. In contrast+to /*...*/ and //... comments, formal comments are stored and output+again when pretty-printing a security protocol theory.++ formal_comment := ident '{*' ident* '*}'++For the syntax of terms, you best look at our examples. A common pitfall is to+use an undefined function symbol. This results in an error message pointing to+a position slightly before the actual use of the function due to some+ambiguity in our grammar.++We provide special syntax for tuples, multiplications, exponentiation, nullary+and binary function symbols. An n-ary tuple <t1,...,tn> is parsed as n-ary,+right-associative application of pairing. Multiplication and exponentiation+are parsed left-associatively. For a binary operator 'enc' you can write+'enc{m}k' or 'enc(m,k)'. For nullary function symbols, there is no need to+write 'nullary()'. Note that the number of arguments of an n-ary function+application must agree with the arity given in the function definition.++ tupleterm := multterm list+ multterm := expterm ('*' expterm)*+ expterm := term ('^' term )*+ term := '<' tupleterm '>' // n-ary right-associative pairing+ | '(' multterm ')' // a nested term+ | nullary_fun+ | binary_app+ | nary_app+ | literal++ nullary_fun := <all-nullary-functions-defined-up-to-here>+ binary_app := binary_fun '{' tupleterm '}' term+ binary_fun := <all-binary-functions-defined-up-to-here>+ nary_app := nary_fun '(' multterm* ')'++ literal := "'" ident "'" // a fixed, public name+ | '$' ident // a variable of sort 'pub'+ | "~'" ident "'" // a fixed, fresh name+ | "~" ident // a variable of sort 'fresh'+ | "#" ident // a variable of sort 'temp'+ | ident // a variable of sort 'msg'++Facts do not have to be defined up-front. This will probably change once we+implement user-defined sorts. Facts prefixed with '!' are persistent facts.+All other facts are linear. There are six reserved fact symbols: In, Out, KU,+KD, K, and Ded. KU and KD facts are used for construction and deconstruction+rules. The 'Ded' fact logs the messages deduced by construction rules. See the+InductionInvariant.spthy example for more information.++ facts := fact list+ fact := ['!'] ident '(' multterm list ')'++Formulas are trace formulas as described in our paper. Note that we are a bit+more liberal with respect to guardedness. We accept a conjunction of atoms as+guards.++ formula := atom | '(' iff ')' | ( 'All' | 'Ex' ) ident+ '.' iff+ iff := imp '<=>' imp+ imp := disjuncts '==>' disjuncts+ disjuctions := conjuncts ('|' disjuncts)+ // left-associative+ conjuncts := negation ('|' disjuncts)+ // left-associative+ negation := 'not' formula++ atom := tvar '<' tvar // ordering of temporal variables+ | '#' ident '=' '#' ident // equality between temporal variables+ | multterm '=' multterm // equality between terms+ | fact '@' tvar // action+ | 'T' // true+ | 'F' // false+ | '(' formula ')' // nested formula++ // Where unambiguous the '#' sort prefix can be dropped.+ tvar := ['#'] ident++Identifiers always start with a character. Moreover, they must not be one of the+reserved keywords 'let', 'in', or 'rule'.++ ident := alpha (alpha | digit)*++++Developing Tamarin+==================++The Tamarin prover is under active development. We are grateful to receive+bug-reports. If you consider building on top of Tamarin, then you might+consider integrating your idea into the main source repository. Please feel+free to contact us such that we can discuss the next steps towards fully+verified systems :-)+
data/etc/spthy.vim view
@@ -51,7 +51,9 @@ syn match spthyConstr "\<symmetric-encryption" syn match spthyConstr "\<asymmetric-encryption" -syn keyword spthyDecl lemma assert equations functions builtin protocol property properties let theory begin end subsection section text note+syn keyword spthyDecl lemma assert equations functions builtins protocol property properties in let theory begin end subsection section text note+syn match spthyDecl "\<exists-trace"+syn match spthyDecl "\<all-traces" syn match spthyDecl "\<enable" syn match spthyDecl "\<rule" syn match spthyDecl "\<assertions"
− data/examples/TLS.spthy
@@ -1,190 +0,0 @@-theory TLS -begin--builtin: hashing, symmetric-encryption, asymmetric-encryption, signing--section{* TLS Handshake *}--/*- * Protocol: TLS Handshake- * Modeler: Simon Meier- * Date: January 2012- * Source: Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy.- *- * Status: working (25 seconds on an i7 Quad-Core CPU with +RTS -N)- */--text{*- Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy. Notable- differences are:-- 1. We use explicit global constants to differentiate between different- encryptions instead of implicit typing.-- 2. We model session keys directly as hashes of the relevant information.- Due to our support for composed keys, we do not need any custom- axiomatization as Paulson does.--*}--// Public key infrastructure-rule Register_pk:- [ Fr(~ltkA) ] - --> - [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ]--rule Reveal_ltk:- [ !Ltk(A, ltkA) ] --[ RevLtk(A) ]-> [ Out(ltkA) ]---/* We formalize the following signature based TLS handshake.-- protocol TLS {- 1. C -> S: C, nc, sid, pc- 2. C <- S: ns, sid, ps-- 3. C -> S: { '31', pms }pk(S) ,- sign{ '32', h('32', ns, S, pms) }pk(C) ,- { '33', sid, h('PRF', pms, nc, ns),- nc, pc, C, ns, ps, S- } - h('clientKey', nc, ns, h('PRF', pms, nc, ns))-- 4. C <- S: { '4', sid, h('PRF', pms, nc, ns),- nc, pc, C, ns, ps, S- } - h('serverKey', nc, ns, h('PRF', pms, nc, ns))- }-*/--rule C_1:- [ Fr(~nc)- , Fr(~sid)- ]- --[]->- [ Out(- <$C, ~nc, ~sid, $pc>- )- , St_C_1($C, ~nc, ~sid, $pc)- ]--rule S_1:- [ In( - <$C, nc, sid, pc>- )- , Fr(~ns)- ]- --[]->- [ Out(- <$S, ~ns, sid, $ps>- )- , St_S_1($S, $C, sid, nc, pc, ~ns, $ps)- ]--rule C_2:- [ St_C_1(C, nc, sid, pc)- , In(- <S, ns, sid, ps>- )- , Fr(~pms)- , !Pk(S, pkS)- , !Ltk(C, ltkC)- ]- --[]->- [ Out(- < aenc{ '31', ~pms }pkS- , sign{ '32', h('32', ns, S, ~pms) }ltkC- , senc{ '33', sid, h('PRF', ~pms, nc, ns), nc, pc, C, ns, ps, S}- h('clientKey', nc, ns, h('PRF', ~pms, nc, ns))- >- )- , St_C_2(S, C, sid, nc, pc, ns, ps, ~pms)- ]--rule S_2:- [ St_S_1(S, C, sid, nc, pc, ns, ps)- , In(- < aenc{ '31', pms }pk(ltkS)- , signature- , senc{ '33', sid, h('PRF', pms, nc, ns), nc, pc, C, ns, ps, S}- h('clientKey', nc, ns, h('PRF', pms, nc, ns))- >- )- , !Pk(C, pkC)- , !Ltk(S, ltkS)- ]- /* Explicit equality check, enforced as part of the property. */- --[ Eq(verify(signature, <'32', h('32', ns, S, pms)>, pkC), true )- , SessionKeys- ( S, C- , h('serverKey', nc, ns, h('PRF', pms, nc, ns))- , h('clientKey', nc, ns, h('PRF', pms, nc, ns))- )- ]->- [ Out(- senc{ '4', sid, h('PRF', pms, nc, ns), nc, pc, C, ns, ps, S}- h('serverKey', nc, ns, h('PRF', pms, nc, ns))- )- ]--rule C_3:- [ St_C_2(S, C, sid, nc, pc, ns, ps, pms)- , In(- senc{ '4', sid, h('PRF', pms, nc, ns), nc, pc, C, ns, ps, S}- h('serverKey', nc, ns, h('PRF', pms, nc, ns))- )- ]- --[ SessionKeys- ( S, C- , h('serverKey', nc, ns, h('PRF', pms, nc, ns))- , h('clientKey', nc, ns, h('PRF', pms, nc, ns))- )- ]->- []---/* TODO: Also model session-key reveals and adapt security properties. */---/* Session key secrecy from the perspecitive of both the server and the client- * for both the key of the server and the key of the client. Note that this- * lemma thus captures four security properties at once. */-lemma session_key_secrecy:- " /* If all equality checks succeeded */- (All x y #i. Eq(x,y) @ i ==> x = y)- ==>- /* then there is no attack */ - (not( - /* It cannot be that */- Ex S C keyS keyC #k.- /* somebody claims to have setup session keys, */- SessionKeys(S, C, keyS, keyC) @ k - /* but the adversary knows one of them */- & ( (Ex #i. K(keyS) @ i) - | (Ex #i. K(keyC) @ i)- )- /* without having performed a long-term key reveal. */- & not (Ex #r. RevLtk(S) @ r)- & not (Ex #r. RevLtk(C) @ r)- ) )"--/* Consistency check: this lemma must NOT have a proof,- * as otherwise no session-keys could be setup between honest agents. */-lemma session_key_setup_possible:- " /* If all equality checks succeeded */- (All x y #i. Eq(x,y) @ i ==> x = y)- ==>- /* then there is no trace */ - (not( - /* It cannot be that */- Ex S C keyS keyC #k.- /* somebody claims to have setup session keys, */- SessionKeys(S, C, keyS, keyC) @ k - /* without having performed a long-term key reveal. */- & not (Ex #r. RevLtk(S) @ r)- & not (Ex #r. RevLtk(C) @ r)- ) )"---end-
− data/examples/UserGuide.spthy
@@ -1,437 +0,0 @@-/*-User guide to the tamarin prover for security protocol analysis-===============================================================--Authors: Simon Meier, Benedikt Schmidt-Date: February 2012---Introduction---------------This user guide assumes that you have a copy of our CSF'12 submission on-"Automated Analysis of Diffie-Hellman Protocols and Advanced Security-Properties". Drop us a mail, if you would like to receive a copy.--The input files for the tamarin prover have the extension .spthy, which is-short for 'security protocol theory'. A security protocol theory specifies-- 1. the signature and equational theory to use for the message algebra,- 2. the set of set of multiset rewriting rules modeling the protocol and- the adversary capabilities, and- 3. the guarded trace properties whose validity for this set of multiset- rewriting rules we want to check.--We explain each of these parts where they occur in the following security-protocol theory. Before we start, a few notes on the syntax.-As you probably noticed, comments are C-style. All identifiers are-case-sensitive. The parser is layout-insensitive, i.e., your are free to use-whitespace as it suits you. For people using the 'vim' text-editor, we provide-syntax highlighting files. We explain how to install them, before we explain-how to model a simple example protocol.---Installing the vim syntax highlighting files-----------------------------------------------As you've probably noticed, calling 'tamarin-prover' without any arguments-yields an informative help-message listing all available flags and the paths-to the installed example protocol files. We call the directory above the-example files the DATA_PATH. The examples are found at-- DATA_PATH/examples--and the 'vim' syntax highlighting files are found at-- DATA_PATH/etc/--To install them, copy-- DATA_PATH/etc/filepath.vim--to the ~/.vim directory and copy-- DATA_PATH/etc/spthy.vim--to the ~/.vim/syntax directory. If one of these directories does not exist,-then just create it.----Modeling a security protocol-------------------------------Every security protocol theory starts with a header of the following form.-*/--theory UserGuide-begin--/*-Obviously, you can replace 'UserGuide' with any name you like to give your-theory. After 'begin', you can declare function symbols, equations that they-must satisfy, multiset rewriting rules, and lemmas specifying security-properties. Moreover, you can also insert formal comments, to structure your-theory. We give examples of each of these elements while modeling the-a simple protocol. --In this protocol a client C generates a fresh symmetric key 'k', encrypts it-with the public key of a server 'S' and sends it to 'S'. The server confirms-the receipt of the key by sending back its hash to the client. In-Alice-and-Bob notation the protocol would read as follows.-- C -> S: aenc{k}pk(S)- S <- C: h(k)--This protocol is artificial and it satisfies only very weak security-guarantees. We can prove that from the perspective of the client, the freshly-generated key is secret provided that the server is uncompromised.--We model this protocol in three steps. First, we declare the function symbols-and the equations defining them. Then, we introduce multiset rewriting rules-modeling a public key infrastructure (PKI) and the protocol. Finally, we state-the expected security properties.---Function Signature and Equational Theory-------------------------------------------We model hashing using the unary function 'h'.-We model asymmetric encryption by declaring - a binary function 'aenc' denoting a call to the encryption algorithm,- a binary function 'adec' denoting a call to the decryption algorithm, and- a unary function 'pk' denoting a call to the algorithm computing a public- key from a private key.-*/--functions: h/1, aenc/2, adec/2, pk/1-equations: adec(aenc(m, pk(k)), k) = m--/*-The above equation then models the interaction between calls to these three-algorithms. All these equations must be subterm-convergent rewriting rules,-when read from left to right. This means that the right-hand-side must be a-subterm of the left-hand-side or a nullary function symbol.--Certain equational theories are used very often when modeling cryptographic-messages. We therefore provide builtin definitions for them. The above theory-could also be enabled using the declaration-- builtin: hashing, asymmetric-encryption--We support the following builtin theories:- - diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,- hashing--Apart from 'diffie-hellman', all of these theories are subterm-convergent and-can therefore also be declared directly, as above. You can inspect their-definitions by uncommenting the following two line-comments and calling-- tamarin-prover UserGuide.spthy--*/--// builtin: diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,-// hashing--/*-The call 'tamarin-prover UserGuide.spthy' parses the UserGuide.spthy file,-computes the variants of the multiset rewriting rules and checks their-wellformedness (explained below), and pretty-prints the theory. The-declaration of the signature and the equations can be found at the top of the-pretty-printed theory.--Proving all lemmas contained in the theory would be as simple as adding the-flag '--prove' to the call; i.e.,-- tamarin-prover UserGuide.spthy --prove--However, let's not go there yet. We first have to model the PKI and our-protocol.--Modeling the Public Key Infrastructure----------------------------------------*/--// Registering a public key-rule Register_pk:- [ Fr(~ltk) ] - --> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)) ]--/* The above rule models registering a public key. It makes use of the- following syntax.- - Facts always start with an upper-case letter. They are declared implicitly.- If their name is prefixed with an exclamation mark '!', then they are- persistent. Otherwise, they are linear. Note that you must use every fact- name consistently; i.e., you must always use it with the same arity, casing,- and multiplicity. Otherwise, the tamarin prover complains that the theory- is not wellformed.-- The 'Fr' fact is a builtin fact. It denotes a freshly generated fresh name.- See the paper for details.-- We denote the sort of variables using prefixes:-- ~x denotes x:fresh- $x denotes x:pub- #i denotes i:temp- i denotes i:msg-- 'c' denotes a public name 'c \in PN'; i.e., a fixed, global constant- - Thus, the above rule can be read as follows. First, freshly generate a- fresh name 'ltk', the new private key and nondeterministically choose a- public name 'A', the agent for which we are generating the key-pair.- Then, generate the persistent fact !Ltk($A, ~ltk), which denotes the- association between agent 'A' and its private key 'ltk, and generate the- persistent fact !Pk($A, pk(~ltk)), which denotes the association between the- agent 'A' and its public key 'pk(~ltk)'.-- We allow the adversary to retrieve any public key using the following rule.- Intuitively, it just reads a public-key database entry and sends the public- key to the network using the builtin fact 'Out' denoting a message sent to- the network. See our paper for more information.-*/--rule Get_pk:- [ !Pk(A, pk) ] - --> - [ Out(pk) ]--/*- We model dynamic compromise of long-term private keys using the following- rule. Intuitively, it reads a private-key database entry and sends it to- the adversary. This rule has an observable 'LtkReveal' action stating that- the long-term key of agent 'A' was compromised. We will use this action in- the security property below to determine which agents are compromised.-*/--rule Reveal_ltk:- [ !Ltk(A, ltk) ]- --[ LtkReveal(A) ]->- [ Out(ltk) ]---/*--Modeling the protocol-------------------------Recall that we want to model the following protocol.-- C -> S: aenc{k}pk(S)- S <- C: h(k)--We model it use the following three rules.-*/--// Start a new thread executing the client role, choosing the server-// non-deterministically.-rule Client_1:- [ Fr(~k) // choose fresh key- , !Pk($S, pkS) // lookup public-key of server- ]- -->- [ Client_1( $S, ~k ) // Store server and key for next step of thread- , Out( aenc{'1', ~k}pkS ) // Send the encrypted session key to the server- // We add the tag '1' to the request to allow- // the server to check whether the decryption- // was successful.- ]--rule Init_2:- [ Client_1(S, k) // Retrieve server and session key from previous step- , In( h(k) ) // Receive hashed session key from network- ]- --[ SessKeyC( S, k ) ]-> // State that the session key 'k'- [] // was setup with server 'S'--// A server thread answering in one-step to a session-key setup request from-// some client.-rule Serv_1:- [ !Ltk($S, ~ltkS) // lookup the private-key- , In( request ) // receive a request- ]- --[ Eq(fst(adec(request, ~ltkS)), '1')- , AnswerRequest($S, snd(adec(request, ~ltkS))) // Explanation below- ]-> - [ Out( h(snd(adec(request, ~ltkS))) ) ] // Return the hash of the- // decrypted request.--/* Above, we model all applications of cryptographic algorithms explicitly.- Call 'tamarin-prover UserGuide.spthy' to inspect the finite variants of the- Serv_1 rule, which list all possible interactions of the destructors used.- In our proof search, we will consider all these interactions.-- We also model that the server explicitly checks that the first component of- the request is equal to '1'. We model this by logging the claimed equality- and then adapting the security property such that it only considers traces- where all 'Eq' actions occur with two equal arguments. Note that 'Eq' is NO- builtin fact. Guarded trace properties are strong enough to formalize this- requirement without builtin support.-- We log the session-key setup requests received by servers to allow- formalizing the authentication property for the client.---Modeling the security properties-----------------------------------The syntax for specifying security properties uses-- All for universal quantification, temporal variables are prefixed with #- Ex for existential quantification, temporal variables are prefixed with #- ==> for implication- & for conjunction- | for disjunction- not for negation- - f @ i for action constraints, the sort prefix for the temporal variable 'i'- is optional- - i < j for temporal ordering, the sort prefix for the temporal variable 'i'- is optional-- #i = #j for an equality between temporal variables 'i' and 'j'- x = y for an equality between message variables 'x' and 'y'--Note that apart from public names (delimited using single-quotes), no terms-may occur in guarded trace properties. Moreover, all variables must be-guarded. The error message for an unguarded variable is currently not very-good. --For universally quantified variables, one has to check that they all occur in-an action constraint right after the quantifier and that the toplevel inside-the quantifier is an implication.-For existentially quantified variables, one has to check that they all occur in-an action constraint right after the quantifier and that the toplevel inside-the quantifier is a conjunction.-Note also that currently the precedence of the logical connectives is not-specified. We therefore recommend to use parentheses, when in doubt.---The following two properties should be self-explanatory.-*/--lemma Client_session_key_secrecy:- " /* For all traces, where all equality checks succeed, */- (All x y #i. Eq(x,y) @ i ==> x = y)- ==>- /* it cannot be that a */- not(- Ex S k #i #j.- /* client setup a session key 'k' with a server'S' */- SessKeyC(S, k) @ #i- /* and the adversary knows 'k' */- & K(k) @ #j- /* without having performed a long-term key reveal on 'S'. */- & not(Ex #r. LtkReveal(S) @ r) - )- "---lemma Client_auth:- " /* For all traces, where all equality checks succeed, */- (All x y #i. Eq(x,y) @ i ==> x = y)- ==>- /* for all session keys 'k' setup by clients with a server 'S' */- ( All S k #i. SessKeyC(S, k) @ #i- ==>- /* there is a server that answered the request */- ( (Ex #a. AnswerRequest(S, k) @ a)- /* or the intruder performed a long-term key reveal on 'S'- before the key was setup. */- | (Ex #r. LtkReveal(S) @ r & r < i)- )- )- "--/*- You can verify them by calling-- tamarin-prover --prove UserGuide.spthy-- This will first output some logging from the constraint solver and then the- UserGuide security protocol theory with the lemmas and their attached- (dis)proofs.-- Finding attacks is very useful, to check that a security property is not- trivial due to too strong preconditions. The following property must not be- provable, as otherwise there would be no possibility to setup a session key- with a honest sever.--*/--// Must not be provable!-lemma Client_session_key_honest_setup_possible:- " (All x y #i. Eq(x,y) @ i ==> x = y)- ==>- not(- Ex S k #i.- SessKeyC(S, k) @ #i- & not(Ex #r. LtkReveal(S) @ r) - )- "--/* As you can see from the output of -- tamarin-prover --prove UserGuide.spthy-- It finds an "attack" on this property, as expected. To characterize all- possible attacks use-- tamarin-prover --prove --stop-on-attack=NONE UserGuide.spthy-- You can see from the output that there is exactly one way to setup a session- key with an honest server.---Interactive proof visualization and construction---------------------------------------------------Just call -- tamarin-prover interactive UserGuide.spthy--This will start a web-server that loads all security protocol theories in the-same directory as UserGuide.spthy. Point your browser to-- http://localhost:3001--and explore the the UserGuide theory interactively by clicking on the-'UserGuide' entry in the table of loaded theories. You can prove a lemma-interactively by clicking on the available proof methods (corresponding to-applications of constraint reduction rules) or by calling the 'autoprover' by-right-clicking on a node in the theory overview.---Conclusion-------------The case studies from our CSF'12 submission should now be readable. Recall-that you can find them in the directory listed at the bottom of the help-message, when calling 'tamarin-prover' without any arguments. If you have-further questions, please do not hesitate to contact either-- Benedikt Schmidt benedikt.schmidt@inf.ethz.ch - Simon Meier simon.meier@inf.ethz.ch.--Note that our CSF'12 submission does not explain how we compose multiple-constraint reduction into a precomputed case distinction. It also does not-explain how we delay splitting on the different variants of multiset rewriting-rules. We will report on this in an upcoming technical report. This report-will also explain the support for proving loop invariants by induction, as it-is already supported by this version of 'tamarin'.---BTW, every security protocol theory must be delimited with 'end'.-- (-: HAPPY PROVING :-)-*/--end--
data/examples/csf12/Artificial.spthy view
@@ -12,19 +12,19 @@ illustrate constraint solving and characterization. Note that, for characerization, you have to call the tamarin-prover as follows. - tamarin-prover --prove --stop-on-attack=NONE your_protocol.spthy+ tamarin-prover --prove --stop-on-trace=NONE your_protocol.spthy - The --stop-on-attack=NONE flag ensures that all solved constraint systems+ The --stop-on-trace=NONE flag ensures that all solved constraint systems are explored by the constraint solver. By default, it stops as soon as the- first attack is found. Note that depending on the protocol,+ first trace is found. Note that depending on the protocol, characterization might take a long time, as there are many slightly- different possible attacks.+ different possible traces. As a more interesting example try characterizing the setup of a session-key between two honest agents in the TLS.spthy example, which models a TLS handshake using signatures. - tamarin-prover --prove --stop-on-attack=NONE TLS.spthy +RTS -N+ tamarin-prover --prove --stop-on-trace=NONE TLS.spthy +RTS -N Note that we add the +RTS -N to tell the Haskell runtime system that it should use as many cores as your system provides. For TLS, this speeds-up@@ -33,14 +33,14 @@ finding all counter-examples to this property. Exactly, two of the cases will be of the form - SOLVED (trace found)+ SOLVED // trace found They correspond to the _only_ two ways of setting up a session-key between honest agents: one for the client and one for the server. */ -builtin: symmetric-encryption+builtins: symmetric-encryption rule Step1: [ Fr(~x), Fr(~k) ] @@ -57,8 +57,9 @@ --[ Rev(k) ]-> [ Out(k) ] +// We search for trace-existence, as we want to characterize the possible+// traces satisfying the given formula. lemma Characterize_Fin:- "not( Ex k S #i. Fin(S, k) @ i )- "+ exists-trace "Ex k S #i. Fin(S, k) @ i" end
+ data/examples/csf12/DH2_original.spthy view
@@ -0,0 +1,144 @@+theory DH2_original+begin++builtins: diffie-hellman, hashing++section{* DH2 *}++/*+ * Protocol: DH2+ * Modeler: Cas Cremers+ * Date: April 2012+ * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol"+ * Chatterjee, Menezes, Ustaoglu, 2011+ * Model: Original model from the above paper + * (a restricted version of eCK)+ *+ * Status: working+ *+ * Notes: Slightly simplified to use only a single group 'g' instead of allowing participants to choose.+ */++functions: KDF/1+functions: MAC/2++/* Protocol rules */++/* Generate long-term keypair */+rule Register_pk:+ let pkA = 'g'^~ltkA+ in+ [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ]++/* Initiator */+rule Init_1:+ let pkR = 'g'^~ltkR+ X = 'g'^~m1+ XB = pkR^~m1+ in+ [ Fr( ~m1 ), !Ltk( $I, ~ltkI ), !Pk($R,pkR) ]+ --[ Sid( ~m1, $I, $R, <$I, $R, 'Init', XB>)+ , EphKey ( ~m1, ~m1 ) ]->+ [ Init_1( ~m1, $I, $R, ~ltkI, X, XB ), !Ephk( ~m1,~m1 ), Out( XB ) ]++rule Resp_1:+ let pkI = 'g'^~ltkI+ Y = 'g'^~m2+ YA = pkI^~m2+ X = XB^inv(~ltkR)+ key = KDF(< X, Y, $I, $R, XB, YA >)+ tagB = MAC(key, (< 'Resp', $R, $I, YA, XB >) )+ tagA = MAC(key, (< 'Init', $I, $R, XB, YA >) )+ in+ [ Fr( ~m2 ), In( XB ), !Ltk( $R, ~ltkR ), !Pk($I,pkI) ]+ --[ Sid ( ~m2, $R, $I, <$R, $I, 'Resp', YA, XB >)+ , Match( ~m2, <$I, $R, 'Init', XB >)+ //, Match( ~m2, <$I, $R, 'Init', XB, YA >) // Case subsumed: if+ // a matching Sid fact exists, then also a Sid fact exists that+ // matches the previous+ , EphKey ( ~m2, ~m2 )+ ]->+ [ Resp_1( ~m2, $I, $R, YA, XB, tagA, key ), !Ephk( ~m2,~m2 ), Out(< YA , tagB >) ]++rule Init_2:+ let pkR = 'g'^~ltkR+ Y = YA^inv(~ltkI)+ key = KDF(< X, Y, $I, $R, XB, YA >)+ tagB = MAC(key, (< 'Resp', $R, $I, YA, XB >) )+ tagA = MAC(key, (< 'Init', $I, $R, XB, YA >) )+ in+ [ Init_1( ~m1, $I, $R, ~ltkI, X, XB ) , In(< YA, tagB >) ]+ --[ Sid ( ~m1, $I, $R, <$I, $R, 'Init', XB, YA > )+ , Match( ~m1, <$R, $I, 'Resp', YA, XB > )+ , Accept( ~m1, $I, $R, key) + ]->+ [ Out(< YA, XB, tagA >), !Sessk( ~m1, key ) ]++rule Resp_2:+ [ Resp_1( ~m2, $I, $R, YA, XB, tagA, key), In(< YA, XB, tagA >) ]+ --[ Accept( ~m2, $R, $I, key) ]->+ [ !Sessk( ~m2, key ) ]++++/* Key Reveals for the eCK model */+rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ltk_reveal:+ [ !Ltk($A, lkA) ]+ --[ LtkRev($A) ]->+ [ Out(lkA) ]++rule Ephk_reveal:+ [ !Ephk(~s, ~ek) ]+ --[ EphkRev(~s) ]->+ [ Out(~ek) ]+++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 #i3 #i4 s ss k A B minfo.+ Accept(s, k) @ i1+ & Accept(ss, k) @ i2+ & Sid(s, A, B, minfo) @ i3+ & Match(ss, minfo) @ i4+ )"+*/+ +lemma KAS_key_secrecy:+ "not (Ex #i1 #i2 s A B k .+ Accept(s, A, B, k) @ i1 & K( k ) @ i2 ++ /* No session-key-reveal of test thread. */+ & not(Ex #i4. SesskRev( s ) @ i4 )++ /* If matching session exists (for all matching sessions...) */+ & (All ss #i4 #i5 C D ms.+ ( Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5)+ ==>+ ( not(Ex #i6 . SesskRev( ss ) @ i6 )+ & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & EphkRev ( s ) @ i7 )+ & not(Ex #i6 #i7. LtkRev ( B ) @ i6 & EphkRev ( ss ) @ i7 )+ & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & LtkRev ( B ) @ i7 )+ & not(Ex #i6 #i7. EphkRev ( s ) @ i6 & EphkRev ( ss ) @ i7 )+ )+ )++ /* No matching session exists */+ & ( ( not(Ex ss #i4 #i5 C D ms.+ Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) )+ ==>+ ( not(Ex #i6. EphkRev ( s ) @ i6 )+ & not(Ex #i6. LtkRev ( B ) @ i6 & i6 < i1 )+ )+ )+ )"++end
− data/examples/csf12/JKL_TS1_2004-KI.spthy
@@ -1,116 +0,0 @@-theory JKL_TS1_2004-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS1 (2004) *}--/*- * Protocol: JKL-TS1-2004- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2004.- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, ~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ),- !Ephk(~ekI),- Out( ~ekI ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, ~ekI, Y,- h( < ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]->- [ !Sessk( ~ekI, - h( < ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]--rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, ~ekR ,- h( < X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]->- [ Out( ~ekR ),- !Ephk(~ekR),- !Sessk( ~ekR, - h( < X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]--/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--end
+ data/examples/csf12/JKL_TS1_2004_KI.spthy view
@@ -0,0 +1,126 @@+theory JKL_TS1_2004_KI+begin++builtins: hashing, diffie-hellman++section{* Jeong, Katz, Lee : TS1 (2004) *}++/*+ * Protocol: JKL-TS1-2004+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"+ * Jeong, Katz, Lee, 2004.+ *+ * Status: working+ */++/* Protocol rules */++rule generate_ltk:+ let pkA = 'g'^~lkA+ in+ [ Fr(~lkA) ] -->+ [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ]++rule Init_1:+ [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]+ --[ SidI_1(~ekI,$I,$R, ~ekI )+ , NotEq($I,$R) // Inequality of names required, enforced in the property+ ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ),+ !Ephk(~ekI),+ Out( ~ekI ) ]++rule Init_2:+ let pkR = 'g'^~lkR+ key = h( < ~ekI, Y, pkR^~lkI > )+ in+ [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R, pkR ) ]+ --[SidI_2( ~ekI, $I, $R, ~ekI, Y, key) ]->+ [ !Sessk( ~ekI, key ) ]++rule Resp_1:+ let pkI = 'g'^~lkI+ key = h( < X, ~ekR, pkI^~lkR > )+ in+ [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, pkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, ~ekR, key)+ , NotEq($I,$R) // Inequality of names required, enforced in the property+ ]->+ [ Out( ~ekR ),+ !Ephk(~ekR),+ !Sessk( ~ekR, key) ]++rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ephk_reveal:+ [ !Ephk(~ekI) ]+ --[ EphkRev(~ekI) ]->+ [ Out(~ekI) ]++rule Ltk_reveal:+ [ !Ltk($A, k) ]+ --[ LtkRev($A) ]->+ [ Out(k) ]++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_1_initiator_key:+ "(not (Ex #i x . NotEq(x,x) @ i ) ) ==> // Only consider traces in which the inequalities hold+ not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_1_responder_key:+ "(not (Ex #i x . NotEq(x,x) @ i ) ) ==>+ not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"++end
− data/examples/csf12/JKL_TS1_2008-KI.spthy
@@ -1,120 +0,0 @@-theory JKL_TS1_2008-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS1 (2008) *}-/*- * Protocol: JKL-TS1-2008- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2008- * Note: Although the paper title is the same as the 2004- * original, the updated version from 2008 includes- * modified protocols and security models.- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, ~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ),- !Ephk(~ekI),- Out( ~ekI ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, ~ekI, Y,- h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]->- [ !Sessk( ~ekI, - h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]--rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, ~ekR ,- h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]->- [ Out( ~ekR ),- !Ephk(~ekR),- !Sessk( ~ekR, - h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]---/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--end-
− data/examples/csf12/JKL_TS1_2008-KI_wPFS.spthy
@@ -1,139 +0,0 @@-theory JKL_TS1_2008-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS1 (2008) *}--/*- * Protocol: JKL-TS1-2008- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2008- * Note: Although the paper title is the same as the 2004- * original, the updated version from 2008 includes- * modified protocols and security models.- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, ~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ),- !Ephk(~ekI),- Out( ~ekI ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, ~ekI, Y,- h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]->- [ !Sessk( ~ekI, - h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]--rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, ~ekR ,- h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]->- [ Out( ~ekR ),- !Ephk(~ekR),- !Sessk( ~ekR, - h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]--/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion) */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the actor or intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion)- */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- )"--end-
+ data/examples/csf12/JKL_TS1_2008_KI.spthy view
@@ -0,0 +1,120 @@+theory JKL_TS1_2008_KI+begin++builtins: hashing, diffie-hellman++section{* Jeong, Katz, Lee : TS1 (2008) *}+/*+ * Protocol: JKL-TS1-2008+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"+ * Jeong, Katz, Lee, 2008+ * Note: Although the paper title is the same as the 2004+ * original, the updated version from 2008 includes+ * modified protocols and security models.+ *+ * Status: working+ */++/* Protocol rules */++rule generate_ltk:+ [ Fr(~lk) ] -->+ [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]++rule Init_1:+ [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]+ --[ SidI_1(~ekI,$I,$R, ~ekI ) ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, ~ekI ),+ !Ephk(~ekI),+ Out( ~ekI ) ]++rule Init_2:+ [ Init_1( ~ekI, $I, $R, ~lkI , ~ekI), In( Y ), !Pk( $R,'g'^~lkR ) ]+ --[SidI_2( ~ekI, $I, $R, ~ekI, Y,+ h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]->+ [ !Sessk( ~ekI, + h( < $I, $R, ~ekI, Y, ('g'^~lkR)^~lkI > ) ) ]++rule Resp_1:+ [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, ~ekR ,+ h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]->+ [ Out( ~ekR ),+ !Ephk(~ekR),+ !Sessk( ~ekR, + h( < $I, $R, X, ~ekR, ('g'^~lkI)^~lkR > ) ) ]++rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ephk_reveal:+ [ !Ephk(~ekI) ]+ --[ EphkRev(~ekI) ]->+ [ Out(~ekI) ]++rule Ltk_reveal:+ [ !Ltk($A, k) ]+ --[ LtkRev($A) ]->+ [ Out(k) ]+++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_1_initiator_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_1_responder_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"++end+
− data/examples/csf12/JKL_TS2_2004-KI.spthy
@@ -1,117 +0,0 @@-theory JKL_TS2_2004-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS2 (2004) *}-/*- * Protocol: JKL-TS2-2004- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2004- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),- !Ephk(~ekI),- Out( 'g'^~ekI ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]->- [ !Sessk( ~ekI, - h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]--rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]->- [ Out( 'g'^~ekR ),- !Ephk(~ekR),- !Sessk( ~ekR, - h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]---/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/---/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--end
− data/examples/csf12/JKL_TS2_2004-KI_wPFS.spthy
@@ -1,135 +0,0 @@-theory JKL_TS2_2004-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS2 (2004) *}-/*- * Protocol: JKL-TS2-2004- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2004- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),- !Ephk(~ekI),- Out( 'g'^~ekI ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]->- [ !Sessk( ~ekI, - h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]--rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]->- [ Out( 'g'^~ekR ),- !Ephk(~ekR),- !Sessk( ~ekR, - h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]--/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/---/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion) */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the actor or intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion)- */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- )"--end
+ data/examples/csf12/JKL_TS2_2004_KI_wPFS.spthy view
@@ -0,0 +1,135 @@+theory JKL_TS2_2004_KI_wPFS+begin++builtins: hashing, diffie-hellman++section{* Jeong, Katz, Lee : TS2 (2004) *}+/*+ * Protocol: JKL-TS2-2004+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"+ * Jeong, Katz, Lee, 2004+ *+ * Status: working+ */++/* Protocol rules */++rule generate_ltk:+ [ Fr(~lk) ] -->+ [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]++rule Init_1:+ [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]+ --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),+ !Ephk(~ekI),+ Out( 'g'^~ekI ) ]++rule Init_2:+ [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]+ --[SidI_2( ~ekI, $I, $R, hkI, Y,+ h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]->+ [ !Sessk( ~ekI, + h( < hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]++rule Resp_1:+ [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,+ h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]->+ [ Out( 'g'^~ekR ),+ !Ephk(~ekR),+ !Sessk( ~ekR, + h( < X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]++rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ephk_reveal:+ [ !Ephk(~ekI) ]+ --[ EphkRev(~ekI) ]->+ [ Out(~ekI) ]++rule Ltk_reveal:+ [ !Ltk($A, k) ]+ --[ LtkRev($A) ]->+ [ Out(k) ]++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/+++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_2_initiator_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion) */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_2_responder_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the actor or intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion)+ */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ )"++end
− data/examples/csf12/JKL_TS2_2008-KI.spthy
@@ -1,120 +0,0 @@-theory JKL_TS2_2008-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS2 (2008) *}-/*- * Protocol: JKL-TS2-2008- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2008- * Note: Although the paper title is the same as the 2004- * original, the updated version from 2008 includes- * modified protocols and security models.- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),- !Ephk(~ekI),- Out( 'g'^~ekI ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]->- [ !Sessk( ~ekI, - h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]--rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]->- [ Out( 'g'^~ekR ),- !Ephk(~ekR),- !Sessk( ~ekR, - h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]---/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/---/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--end
− data/examples/csf12/JKL_TS2_2008-KI_wPFS.spthy
@@ -1,139 +0,0 @@-theory JKL_TS2_2008-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS2 (2008) *}-/*- * Protocol: JKL-TS2-2008- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2008- * Note: Although the paper title is the same as the 2004- * original, the updated version from 2008 includes- * modified protocols and security models.- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),- !Ephk(~ekI),- Out( 'g'^~ekI ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]->- [ !Sessk( ~ekI, - h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]--rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]->- [ Out( 'g'^~ekR ),- !Ephk(~ekR),- !Sessk( ~ekR, - h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]---/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/---/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion) */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the actor or intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion)- */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- )"--end
+ data/examples/csf12/JKL_TS2_2008_KI_wPFS.spthy view
@@ -0,0 +1,139 @@+theory JKL_TS2_2008_KI_wPFS+begin++builtins: hashing, diffie-hellman++section{* Jeong, Katz, Lee : TS2 (2008) *}+/*+ * Protocol: JKL-TS2-2008+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"+ * Jeong, Katz, Lee, 2008+ * Note: Although the paper title is the same as the 2004+ * original, the updated version from 2008 includes+ * modified protocols and security models.+ *+ * Status: working+ */++/* Protocol rules */++rule generate_ltk:+ [ Fr(~lk) ] -->+ [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]++rule Init_1:+ [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]+ --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),+ !Ephk(~ekI),+ Out( 'g'^~ekI ) ]++rule Init_2:+ [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]+ --[SidI_2( ~ekI, $I, $R, hkI, Y,+ h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]->+ [ !Sessk( ~ekI, + h( < $I, $R, hkI, Y, Y^~ekI, ('g'^~lkR)^~lkI > ) ) ]++rule Resp_1:+ [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,+ h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]->+ [ Out( 'g'^~ekR ),+ !Ephk(~ekR),+ !Sessk( ~ekR, + h( < $I, $R, X, 'g'^~ekR, X^~ekR, ('g'^~lkI)^~lkR > ) ) ]++rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ephk_reveal:+ [ !Ephk(~ekI) ]+ --[ EphkRev(~ekI) ]->+ [ Out(~ekI) ]++rule Ltk_reveal:+ [ !Ltk($A, k) ]+ --[ LtkRev($A) ]->+ [ Out(k) ]+++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/+++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_2_initiator_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion) */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_2_responder_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the actor or intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion)+ */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ )"++end
− data/examples/csf12/JKL_TS3_2004-KI_wPFS.spthy-nonterm
@@ -1,199 +0,0 @@-theory JKL_TS3_2004-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS3 (2004) *}-/*- * Protocol: JKL-TS3-2004- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2004- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ), Roles($I, $R) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),- !Ephk(~ekI),- Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,$I,$R,'g'^~ekI ) > ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR), - In( < Y, h(('g'^~lkI)^~lkR,$R,$I,Y )> ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- Y^~ekI ), Roles($I, $R) ]->- [ !Sessk( ~ekI, - Y^~ekI ) ]--rule Resp_1:- [ In( < X, h( ('g'^~lkR)^~lkI,$I,$R,X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- X^~ekR ), Roles($I, $R) ]->- [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,$R,$I,'g'^~ekR ) > ),- !Ephk(~ekR),- !Sessk( ~ekR, - X^~ekR ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]---/* Security properties */--/* Only non-reflected executions */-/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2- - & (All #tid A. Roles(A, A) @ tid ==> F )- )"-*/--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2004_1_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Only non-reflected executions */- & (All #tid A. Roles(A, A) @ tid ==> F )-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--/*-/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2004_1_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Only non-reflected executions */- & (All #tid A. Roles(A, A) @ tid ==> F )-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2004_2_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Only non-reflected executions */- & (All #tid A. Roles(A, A) @ tid ==> F )-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion) */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2004_2_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Only non-reflected executions */- & (All #tid A. Roles(A, A) @ tid ==> F )-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the actor or intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion)- */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- )"-*/-end
+ data/examples/csf12/JKL_TS3_2004_KI_wPFS.spthy_nonterm view
@@ -0,0 +1,199 @@+theory JKL_TS3_2004_KI_wPFS+begin++builtin: hashing, diffie-hellman++section{* Jeong, Katz, Lee : TS3 (2004) *}+/*+ * Protocol: JKL-TS3-2004+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"+ * Jeong, Katz, Lee, 2004+ *+ * Status: working+ */++/* Protocol rules */++rule generate_ltk:+ [ Fr(~lk) ] -->+ [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]++rule Init_1:+ [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ]+ --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ), Roles($I, $R) ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),+ !Ephk(~ekI),+ Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,$I,$R,'g'^~ekI ) > ) ]++rule Init_2:+ [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR), + In( < Y, h(('g'^~lkI)^~lkR,$R,$I,Y )> ) ]+ --[SidI_2( ~ekI, $I, $R, hkI, Y,+ Y^~ekI ), Roles($I, $R) ]->+ [ !Sessk( ~ekI, + Y^~ekI ) ]++rule Resp_1:+ [ In( < X, h( ('g'^~lkR)^~lkI,$I,$R,X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,+ X^~ekR ), Roles($I, $R) ]->+ [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,$R,$I,'g'^~ekR ) > ),+ !Ephk(~ekR),+ !Sessk( ~ekR, + X^~ekR ) ]++rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ephk_reveal:+ [ !Ephk(~ekI) ]+ --[ EphkRev(~ekI) ]->+ [ Out(~ekI) ]++rule Ltk_reveal:+ [ !Ltk($A, k) ]+ --[ LtkRev($A) ]->+ [ Out(k) ]+++/* Security properties */++/* Only non-reflected executions */+/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2+ + & (All #tid A. Roles(A, A) @ tid ==> F )+ )"+*/++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2004_1_initiator_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Only non-reflected executions */+ & (All #tid A. Roles(A, A) @ tid ==> F )++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"++/*+/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2004_1_responder_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Only non-reflected executions */+ & (All #tid A. Roles(A, A) @ tid ==> F )++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2004_2_initiator_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Only non-reflected executions */+ & (All #tid A. Roles(A, A) @ tid ==> F )++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion) */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2004_2_responder_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Only non-reflected executions */+ & (All #tid A. Roles(A, A) @ tid ==> F )++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the actor or intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion)+ */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ )"+*/+end
− data/examples/csf12/JKL_TS3_2008-KI_wPFS.spthy-nonterm
@@ -1,188 +0,0 @@-theory JKL_TS3_2008-begin--builtin: hashing, diffie-hellman--section{* Jeong, Katz, Lee : TS3 (2008) *}-/*- * Protocol: JKL-TS3-2008- * Modeler: Cas Cremers- * Date: January 2012- * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"- * Jeong, Katz, Lee, 2008- * Note: Although the paper title is the same as the 2004- * original, the updated version from 2008 includes- * modified protocols and security models.- *- * Status: working- */--/* Protocol rules */--rule generate_ltk:- [ Fr(~lk) ] -->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]--rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),- !Ephk(~ekI),- Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,'1','2','g'^~ekI ) > ) ]--rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR),- In( < Y, h(('g'^~lkI)^~lkR,'2','1',Y )> ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- Y^~ekI ) ]->- [ !Sessk( ~ekI, - Y^~ekI ) ]--rule Resp_1:- [ In( < X, h( ('g'^~lkR)^~lkI,'1','2',X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- X^~ekR ) ]->- [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,'2','1','g'^~ekR ) > ),- !Ephk(~ekR),- !Sessk( ~ekR, - X^~ekR ) ]--rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--rule Ephk_reveal:- [ !Ephk(~ekI) ]- --[ EphkRev(~ekI) ]->- [ Out(~ekI) ]--rule Ltk_reveal:- [ !Ltk($A, k) ]- --[ LtkRev($A) ]->- [ Out(k) ]---/* Security properties */--/*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"-*/---/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"-/*--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_1_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not longterm-key-reveal */- & (All #i3 a. LtkRev( a ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_initiator_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. */- & (All #i3 #i4 tpartner kpartner.- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion) */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner kpartner.- (* (i1 < i3) | *)- SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))- )"--/* An attack is valid in the security model if the session key of the test session is deduced and- the test session is clean.-*/-lemma JKL2008_2_responder_key:- "not (Ex #i1 #i2 ttest I R k hkI hkR.- SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not ephemeral-key-reveal */- & (All #i3 t. EphkRev( t ) @ i3 ==> F)-- /* Not session-key-reveal of test thread. */- & (All #i3. SesskRev( ttest ) @ i3 ==> F)-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & (All #i3 #i4 tpartner kpartner.- SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( tpartner ) @ i4 ==> F)-- /* If there is no partner thread, then there is no longterm-key-reveal for- the actor or intended partner.- (We model wpfs, for pfs, add i1 < i3 to conclusion)- */- & (All #i3. LtkRev( I ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- & (All #i3. LtkRev( R ) @ i3 ==>- (Ex #i4 tpartner.- (* (i1 < i3) | *)- SidI_1( tpartner,I,R,hkI ) @i4))- )"-*/--end
+ data/examples/csf12/JKL_TS3_2008_KI_wPFS.spthy_nonterm view
@@ -0,0 +1,188 @@+theory JKL_TS3_2008_KI_wPFS+begin++builtin: hashing, diffie-hellman++section{* Jeong, Katz, Lee : TS3 (2008) *}+/*+ * Protocol: JKL-TS3-2008+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "One-Round Protocols for Two-Party Authenticated Key Exchange"+ * Jeong, Katz, Lee, 2008+ * Note: Although the paper title is the same as the 2004+ * original, the updated version from 2008 includes+ * modified protocols and security models.+ *+ * Status: working+ */++/* Protocol rules */++rule generate_ltk:+ [ Fr(~lk) ] -->+ [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]++rule Init_1:+ [ Fr( ~ekI ), !Ltk( $I, ~lkI ), !Pk($R,'g'^~lkR) ]+ --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),+ !Ephk(~ekI),+ Out( < 'g'^~ekI, h( ('g'^~lkR)^~lkI,'1','2','g'^~ekI ) > ) ]++rule Init_2:+ [ Init_1( ~ekI, $I, $R, ~lkI , hkI), !Pk($R,'g'^~lkR),+ In( < Y, h(('g'^~lkI)^~lkR,'2','1',Y )> ) ]+ --[SidI_2( ~ekI, $I, $R, hkI, Y,+ Y^~ekI ) ]->+ [ !Sessk( ~ekI, + Y^~ekI ) ]++rule Resp_1:+ [ In( < X, h( ('g'^~lkR)^~lkI,'1','2',X ) > ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,+ X^~ekR ) ]->+ [ Out( < 'g'^~ekR, h( ('g'^~lkI)^~lkR,'2','1','g'^~ekR ) > ),+ !Ephk(~ekR),+ !Sessk( ~ekR, + X^~ekR ) ]++rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ephk_reveal:+ [ !Ephk(~ekI) ]+ --[ EphkRev(~ekI) ]->+ [ Out(~ekI) ]++rule Ltk_reveal:+ [ !Ltk($A, k) ]+ --[ LtkRev($A) ]->+ [ Out(k) ]+++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/+++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_1_initiator_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"+/*++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_1_responder_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not longterm-key-reveal */+ & (All #i3 a. LtkRev( a ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_2_initiator_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidI_2(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. */+ & (All #i3 #i4 tpartner kpartner.+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion) */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner kpartner.+ (* (i1 < i3) | *)+ SidR_1( tpartner,I,R,hkI,hkR,kpartner ) @i4))+ )"++/* An attack is valid in the security model if the session key of the test session is deduced and+ the test session is clean.+*/+lemma JKL2008_2_responder_key:+ "not (Ex #i1 #i2 ttest I R k hkI hkR.+ SidR_1(ttest, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2++ /* Not ephemeral-key-reveal */+ & (All #i3 t. EphkRev( t ) @ i3 ==> F)++ /* Not session-key-reveal of test thread. */+ & (All #i3. SesskRev( ttest ) @ i3 ==> F)++ /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.+ A session key reveal can only happen after SidI_2 is logged anyways.+ */+ & (All #i3 #i4 tpartner kpartner.+ SidI_2( tpartner,I,R,hkI,hkR,kpartner ) @i3+ & SesskRev( tpartner ) @ i4 ==> F)++ /* If there is no partner thread, then there is no longterm-key-reveal for+ the actor or intended partner.+ (We model wpfs, for pfs, add i1 < i3 to conclusion)+ */+ & (All #i3. LtkRev( I ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ & (All #i3. LtkRev( R ) @ i3 ==>+ (Ex #i4 tpartner.+ (* (i1 < i3) | *)+ SidI_1( tpartner,I,R,hkI ) @i4))+ )"+*/++end
+ data/examples/csf12/KAS1.spthy view
@@ -0,0 +1,129 @@+theory KAS1+begin++builtins: hashing, asymmetric-encryption++section{* KAS1 *}++/*+ * Protocol: KAS1+ * Modeler: Cas Cremers+ * Date: April 2012+ * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol"+ * Chatterjee, Menezes, Ustaoglu, 2011+ * Model: Weakened version of the model for the initiator only,+ * motivated by the informal remarks for KAS1 security in the paper.+ *+ * Status: working+ *+ * Notes: Confirming the results from the paper, we find that we+ * cannot allow:+ * - compromise of the peer's long-term key+ * - compromise of the test session's ephemeral key+ *+ * The model covers KCI and KI.+ */++functions: KDF/1+functions: MAC/2++/* Protocol rules */++/* Generate long-term keypair */+rule Register_pk:+ let pkA = pk(~ltkA)+ in+ [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ]++/* Initiator */+rule Init_K1_1:+ let c1 = aenc{ ~m1 }pkR+ in+ [ Fr( ~m1 ), !Ltk( $I, ~lkI ), !Pk($R,pkR) ]+ --[ SidI ( ~m1, $I, $R, <$I, $R, 'Init', c1>) ]->+ [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1), !Ephk( ~m1,~m1 ), Out( c1 ) ]++rule Resp_K1_1:+ let m1 = adec(c1, ~lkR)+ nonceB = ~m2+ key = KDF(< m1, $I, $R, nonceB, c1 >)+ tagB = MAC(key, (< 'KC_1_V', $R, $I, nonceB, c1 >) )+ in+ [ Fr( ~m2 ), In( c1 ), !Ltk( $R, ~lkR ), !Pk($I,pkI) ]+ --[ SidR ( ~m2, $R, $I, <$R, $I, 'Resp', nonceB, c1>)+ , Match( ~m2, <$I, $R, 'Init', c1>)+ , Match( ~m2, <$I, $R, 'Init', c1, nonceB>)+ ]->+ [ Out(< nonceB , tagB >), !Sessk( ~m2, key ) ]++rule Init_K1_2:+ let m2 = adec(nonceB, ~lkI)+ key = KDF(< ~m1, $I, $R, nonceB, c1 >)+ tagB = MAC( key, (< 'KC_1_V', $R, $I, nonceB, c1 >) )+ in+ [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1 ) , In(< nonceB, tagB >) ]+ --[ SidI ( ~m1, $I, $R, <$I, $R, 'Init', c1, nonceB> )+ , Match( ~m1, <$R, $I, 'Resp', nonceB, c1> )+ , Accept( ~m1, $I, $R, key) + ]->+ [ !Sessk( ~m1, key ) ]+++++/* Key Reveals for the eCK model */+rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ltk_reveal:+ [ !Ltk($A, lkA) ]+ --[ LtkRev($A) ]->+ [ Out(lkA) ]++rule Ephk_reveal:+ [ !Ephk(~s, ~ek) ]+ --[ EphkRev(~s) ]->+ [ Out(~ek) ]+++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/+lemma KAS1_key_secrecy:+ "not (Ex #i1 #i2 s A B k .+ Accept(s, A, B, k) @ i1 & K( k ) @ i2 ++ /* No session-key-reveal of test thread. */+ & not(Ex #i4. SesskRev( s ) @ i4 )++ /* No ephemeral key reveal of the test thread */+ & not(Ex #i4. EphkRev( s ) @ i4 )++ /* If matching session exists (for all matching sessions...) */+ & (All ss #i4 #i5 C D ms.+ ( SidR ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5)+ ==>+ ( not(Ex #i6 . SesskRev( ss ) @ i6 )+ & not(Ex #i6 . LtkRev ( B ) @ i6 )+ & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & LtkRev ( B ) @ i7 )+ )+ )++ /* No matching session exists */+ & ( ( not(Ex ss #i4 #i5 C D ms.+ SidR ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) )+ ==>+ ( not(Ex #i6. LtkRev ( B ) @ i6 & i6 < i1 )+ )+ )+ )"++end
+ data/examples/csf12/KAS2_eCK.spthy view
@@ -0,0 +1,128 @@+theory KAS2_eCK+begin++builtins: hashing, asymmetric-encryption++section{* KAS2 *}++/*+ * Protocol: KAS2+ * Modeler: Cas Cremers+ * Date: April 2012+ * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol"+ * Chatterjee, Menezes, Ustaoglu, 2011+ * Model: eCK+ *+ * Status: working+ */++functions: KDF/1+functions: MAC/2++/* Protocol rules */++/* Generate long-term keypair */+rule Register_pk:+ let pkA = pk(~ltkA)+ in+ [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ]++/* Initiator */+rule Init_1:+ let c1 = aenc{ ~m1 }pkR+ in+ [ Fr( ~m1 ), !Ltk( $I, ~lkI ), !Pk($R,pkR) ]+ --[ Sid( ~m1, $I, $R, <$I, $R, 'Init', c1>) ]->+ [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1), !Ephk( ~m1,~m1 ), Out( c1 ) ]++rule Resp_1:+ let m1 = adec(c1, ~lkR)+ c2 = aenc{ ~m2 }pkI+ key = KDF(< m1, ~m2, $I, $R, c1, c2 >)+ tagR = MAC(key, (< 'Resp', $R, $I, c2, c1 >) )+ in+ [ Fr( ~m2 ), In( c1 ), !Ltk( $R, ~lkR ), !Pk($I,pkI) ]+ --[ Sid ( ~m2, $R, $I, <$R, $I, 'Resp', c2, c1>)+ , Match( ~m2, <$I, $R, 'Init', c1>)+ , Match( ~m2, <$I, $R, 'Init', c1, c2>)+ ]->+ [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2 ), !Ephk( ~m2,~m2 ), Out(< c2 , tagR >) ]++rule Init_2:+ let m2 = adec(c2, ~lkI)+ key = KDF(< ~m1, m2, $I, $R, c1, c2 >)+ tagR = MAC( key, (< 'Resp', $R, $I, c2, c1 >) )+ tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) )+ in+ [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1 ) , In(< c2, tagR >) ]+ --[ Sid ( ~m1, $I, $R, <$I, $R, 'Init', c1, c2> )+ , Match( ~m1, <$R, $I, 'Resp', c2, c1> )+ , Accept( ~m1, $I, $R, key) + ]->+ [ Out( tagI ), !Sessk( ~m1, key ) ]++rule Resp_2:+ let + key = KDF(< m1, ~m2, $I, $R, c1, c2 >)+ tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) )+ in+ [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2), In( tagI ) ]+ --[ Accept( ~m2, $R, $I, key) ]->+ [ !Sessk( ~m2, key ) ]++++/* Key Reveals for the eCK model */+rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ltk_reveal:+ [ !Ltk($A, lkA) ]+ --[ LtkRev($A) ]->+ [ Out(lkA) ]++rule Ephk_reveal:+ [ !Ephk(~s, ~ek) ]+ --[ EphkRev(~s) ]->+ [ Out(~ek) ]+++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/+lemma eCK_key_secrecy:+ "not (Ex #i1 #i2 s A B k .+ Accept(s, A, B, k) @ i1 & K( k ) @ i2 ++ /* No session-key-reveal of test thread. */+ & not(Ex #i4. SesskRev( s ) @ i4 )++ /* If matching session exists (for all matching sessions...) */+ & (All ss #i4 #i5 C D ms.+ ( Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5)+ ==>+ ( not(Ex #i6 . SesskRev( ss ) @ i6 )+ & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & EphkRev ( s ) @ i7 )+ & not(Ex #i6 #i7. LtkRev ( B ) @ i6 & EphkRev ( ss ) @ i7 )+ )+ )++ /* No matching session exists */+ & ( ( not(Ex ss #i4 #i5 C D ms.+ Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) )+ ==>+ ( not(Ex #i6 . LtkRev (B) @ i6 )+ & not(Ex #i6 #i7. LtkRev (A) @ i6 & EphkRev ( s ) @ i7 )+ )+ )+ )"++end
+ data/examples/csf12/KAS2_original.spthy view
@@ -0,0 +1,131 @@+theory KAS2_original+begin++builtins: hashing, asymmetric-encryption++section{* KAS2 *}++/*+ * Protocol: KAS2+ * Modeler: Cas Cremers+ * Date: April 2012+ * Source: "A Generic Variant of NISTS's KAS2 Key Agreement Protocol"+ * Chatterjee, Menezes, Ustaoglu, 2011+ * Model: Original model from the above paper + * (a restricted version of eCK)+ *+ * Status: working+ */++functions: KDF/1+functions: MAC/2++/* Protocol rules */++/* Generate long-term keypair */+rule Register_pk:+ let pkA = pk(~ltkA)+ in+ [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pkA), Out(pkA) ]++/* Initiator */+rule Init_1:+ let c1 = aenc{ ~m1 }pkR+ in+ [ Fr( ~m1 ), !Ltk( $I, ~lkI ), !Pk($R,pkR) ]+ --[ Sid( ~m1, $I, $R, <$I, $R, 'Init', c1>) ]->+ [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1), !Ephk( ~m1,~m1 ), Out( c1 ) ]++rule Resp_1:+ let m1 = adec(c1, ~lkR)+ c2 = aenc{ ~m2 }pkI+ key = KDF(< m1, ~m2, $I, $R, c1, c2 >)+ tagR = MAC(key, (< 'Resp', $R, $I, c2, c1 >) )+ in+ [ Fr( ~m2 ), In( c1 ), !Ltk( $R, ~lkR ), !Pk($I,pkI) ]+ --[ Sid ( ~m2, $R, $I, <$R, $I, 'Resp', c2, c1>)+ , Match( ~m2, <$I, $R, 'Init', c1>)+ , Match( ~m2, <$I, $R, 'Init', c1, c2>)+ ]->+ [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2 ), !Ephk( ~m2,~m2 ), Out(< c2 , tagR >) ]++rule Init_2:+ let m2 = adec(c2, ~lkI)+ key = KDF(< ~m1, m2, $I, $R, c1, c2 >)+ tagR = MAC( key, (< 'Resp', $R, $I, c2, c1 >) )+ tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) )+ in+ [ Init_1( ~m1, $I, $R, ~lkI, ~m1, c1 ) , In(< c2, tagR >) ]+ --[ Sid ( ~m1, $I, $R, <$I, $R, 'Init', c1, c2> )+ , Match( ~m1, <$R, $I, 'Resp', c2, c1> )+ , Accept( ~m1, $I, $R, key) + ]->+ [ Out( tagI ), !Sessk( ~m1, key ) ]++rule Resp_2:+ let + key = KDF(< m1, ~m2, $I, $R, c1, c2 >)+ tagI = MAC( key, (< 'Init', $I, $R, c1, c2 >) )+ in+ [ Resp_1( ~m2, $I, $R, ~lkR, m1, ~m2, c1, c2), In( tagI ) ]+ --[ Accept( ~m2, $R, $I, key) ]->+ [ !Sessk( ~m2, key ) ]++++/* Key Reveals for the eCK model */+rule Sessk_reveal: + [ !Sessk(~tid, k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++rule Ltk_reveal:+ [ !Ltk($A, lkA) ]+ --[ LtkRev($A) ]->+ [ Out(lkA) ]++rule Ephk_reveal:+ [ !Ephk(~s, ~ek) ]+ --[ EphkRev(~s) ]->+ [ Out(~ek) ]+++/* Security properties */++/*+lemma key_agreement_reachable:+ "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.+ SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+*/+lemma KAS_key_secrecy:+ "not (Ex #i1 #i2 s A B k .+ Accept(s, A, B, k) @ i1 & K( k ) @ i2 ++ /* No session-key-reveal of test thread. */+ & not(Ex #i4. SesskRev( s ) @ i4 )++ /* If matching session exists (for all matching sessions...) */+ & (All ss #i4 #i5 C D ms.+ ( Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5)+ ==>+ ( not(Ex #i6 . SesskRev( ss ) @ i6 )+ & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & EphkRev ( s ) @ i7 )+ & not(Ex #i6 #i7. LtkRev ( B ) @ i6 & EphkRev ( ss ) @ i7 )+ & not(Ex #i6 #i7. LtkRev ( A ) @ i6 & LtkRev ( B ) @ i7 )+ & not(Ex #i6 #i7. EphkRev ( s ) @ i6 & EphkRev ( ss ) @ i7 )+ )+ )++ /* No matching session exists */+ & ( ( not(Ex ss #i4 #i5 C D ms.+ Sid ( ss, C, D, ms ) @ i4 & Match( s, ms ) @ i5 ) )+ ==>+ ( not(Ex #i6. EphkRev ( s ) @ i6 )+ & not(Ex #i6. LtkRev ( B ) @ i6 & i6 < i1 )+ )+ )+ )"++end
data/examples/csf12/KEA_plus_KI_KCI.spthy view
@@ -1,13 +1,13 @@-theory KEA_plus_KCI+theory KEA_plus_KI_KCI begin -builtin: hashing, diffie-hellman+builtins: hashing, diffie-hellman section{* KEA+ *} /* * Protocol: KEA+ * Modeler: Cas Cremers- * Date: January 2012+ * Date: January/April 2012 * Source: "Security Analysis of KEA Authenticated Key Exchange Protocol" * Lauter, Mityagin, 2006 * Property: KI, KCI@@ -18,33 +18,42 @@ /* Protocol rules */ rule generate_ltk:- [ Fr(~lk) ] + let pkA = 'g'^~lkA+ in+ [ Fr(~lkA) ] --[ RegKey($A) ]->- [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ]+ [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ] rule Init_1:+ let epkI = 'g'^~ekI+ in [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),+ --[ SidI_1(~ekI, $I, $R, epkI ) ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, epkI ), !Ephk(~ekI),- Out( 'g'^~ekI ) ]+ Out( epkI ) ] rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( <Y^~lkI, ('g'^~lkR)^~ekI, $I, $R > ) ) ]->- [ !Sessk( ~ekI, - h( <Y^~lkI, ('g'^~lkR)^~ekI, $I, $R > ) ) ]+ let pkR = 'g'^~lkR+ key = h( <Y^~lkI, pkR^~ekI, $I, $R > ) + in+ [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R, pkR ) ]+ --[SidI_2( ~ekI, $I, $R, hkI, Y, key ) ]->+ [ !Sessk( ~ekI, key ) ] rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ]->+ let pkI = 'g'^~lkI+ epkR = 'g'^~ekR+ key = h(< pkI^~ekR, X^~lkR, $I, $R >)+ in+ [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, pkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, epkR , key ) ]-> [ Out( 'g'^~ekR ), !Ephk(~ekR),- !Sessk( ~ekR, - h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ]+ !Sessk( ~ekR, key) ]++ rule Sessk_reveal: [ !Sessk(~tid, k) ]
data/examples/csf12/KEA_plus_KI_KCI_wPFS.spthy view
@@ -1,13 +1,13 @@-theory KEA_plus_wPFS+theory KEA_plus_KI_KCI_wPFS begin -builtin: hashing, diffie-hellman+builtins: hashing, diffie-hellman section{* KEA+ *} /* * Protocol: KEA+ * Modeler: Cas Cremers- * Date: January 2012+ * Date: January/April 2012 * Source: "Security Analysis of KEA Authenticated Key Exchange Protocol" * Lauter, Mityagin, 2006 * Property: KI, KCI, wPFS@@ -22,28 +22,35 @@ [ !Ltk( $A, ~lk ), !Pk( $A, 'g'^~lk ), Out( 'g'^~lk ) ] rule Init_1:+ let epkI = 'g'^~ekI+ in [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^~ekI ) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^~ekI ),+ --[ SidI_1(~ekI, $I, $R, epkI ) ]->+ [ Init_1( ~ekI, $I, $R, ~lkI, epkI ), !Ephk(~ekI),- Out( 'g'^~ekI ) ]+ Out( epkI ) ] rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( <Y^~lkI, ('g'^~lkR)^~ekI, $I, $R > ) ) ]->- [ !Sessk( ~ekI, - h( <Y^~lkI, ('g'^~lkR)^~ekI, $I, $R > ) ) ]+ let pkR = 'g'^~lkR+ key = h( <Y^~lkI, pkR^~ekI, $I, $R > ) + in+ [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R, pkR ) ]+ --[SidI_2( ~ekI, $I, $R, hkI, Y, key ) ]->+ [ !Sessk( ~ekI, key ) ] rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^~ekR ,- h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ]->+ let pkI = 'g'^~lkI+ epkR = 'g'^~ekR+ key = h(< pkI^~ekR, X^~lkR, $I, $R >)+ in+ [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, pkI) ]+ --[ SidR_1( ~ekR, $I, $R, X, epkR , key ) ]-> [ Out( 'g'^~ekR ), !Ephk(~ekR),- !Sessk( ~ekR, - h( <('g'^~lkI)^~ekR, X^~lkR, $I, $R > ) ) ]+ !Sessk( ~ekR, key) ]++ rule Sessk_reveal: [ !Sessk(~tid, k) ]
data/examples/csf12/KEA_plus_eCK.spthy view
@@ -1,7 +1,7 @@-theory KEA_plus_KCI_wPFS+theory KEA_plus_eCK begin -builtin: hashing, diffie-hellman+builtins: hashing, diffie-hellman section{* KEA+ *} /*
data/examples/csf12/NAXOS_eCK.spthy view
@@ -1,21 +1,24 @@ theory NAXOS_eCK begin -builtin: diffie-hellman, hashing+builtins: diffie-hellman section{* NAXOS *} /* * Protocol: NAXOS * Modeler: Cas Cremers, Benedikt Schmidt- * Date: January 2012+ * Date: January 2012/April 2012 * Source: "Stronger Security of Authenticated Key Exchange" * LaMacchia, Lauter, Mityagin, 2007 * Property: eCK security *- * Status: working+ * Status: Working */ +functions: h1/1+functions: h2/1+ /* Protocol rules */ /* In the description in the paper, we omitted the sorts. @@ -26,131 +29,125 @@ /* Generate long-term keypair */ rule generate_ltk:- [ Fr(~lkA) ] -->- [ !Ltk( $A, ~lkA ), !Pk( $A, 'g'^~lkA ), Out( 'g'^~lkA ) ]+ let pkA = 'g'^~lkA + in+ [ Fr(~lkA) ] + --[ RegKey($A) ]->+ [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ] /* Initiator */-/* To formulate the responder property, we also define a SidI action for- * the first rule. For brevity, we omitted this from the description in- * the paper because there the responder property is not specified. */- rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^h(< '1', ~ekI, ~lkI >)) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^h(< '1', ~ekI, ~lkI >) ),- !Ephk(~ekI),- Out( 'g'^h(< '1', ~ekI, ~lkI >) ) ]+ let exI = h1(<~eskI, ~lkI >)+ hkI = 'g'^exI+ in+ [ Fr( ~eskI ), !Ltk( $I, ~lkI ) ]+ -->+ [ Init_1( ~eskI, $I, $R, ~lkI, hkI )+ , !Ephk(~eskI, ~eskI)+ , Out( hkI ) ] rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( < '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI>), Y^h(< '1', ~ekI, ~lkI>), $I, $R> ) ) ]->- [ !Sessk( ~ekI, - h(< '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI> ), Y^h(< '1', ~ekI, ~lkI >), $I, $R>) ) ]+ let pkR = 'g'^~lkR+ exI = h1(< ~eskI, ~lkI >)+ kI = h2(< Y^~lkI, pkR^exI, Y^exI, $I, $R >) + in+ [ Init_1( ~eskI, $I, $R, ~lkI , hkI), !Pk( $R, pkR ), In( Y ) ]+ --[ Accept( ~eskI, $I, $R, kI)+ , Sid( ~eskI, < 'Init', $I, $R, hkI, Y >)+ , Match( ~eskI, < 'Resp', $R, $I, hkI, Y >)+ ]->+ [ !Sessk( ~eskI, kI) ] /* Responder */ rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^h( < '1', ~ekR, ~lkR > ),- h(< '2', ('g'^~lkI)^h(< '1', ~ekR, ~lkR >) ,X^~lkR, X^h(< '1', ~ekR, ~lkR >), $I, $R >) ) ]->- [ Out( 'g'^h(<'1', ~ekR, ~lkR >) ),- !Ephk(~ekR),- !Sessk( ~ekR, - h(< '2', ('g'^~lkI)^h(<'1', ~ekR, ~lkR >) ,X^~lkR, X^h(<'1', ~ekR, ~lkR >), $I, $R >) ) ]+ let pkI = 'g'^~lkI+ exR = h1(< ~eskR, ~lkR >)+ hkr = 'g'^exR+ kR = h2(< pkI^exR, X^~lkR, X^exR, $I, $R >) + in+ [ Fr( ~eskR ), !Ltk($R, ~lkR), !Pk($I, pkI), In( X ) ]+ --[ Accept( ~eskR, $R, $I, kR )+ , Sid( ~eskR, <'Resp', $R, $I, X, hkr >)+ , Match( ~eskR, <'Init', $I, $R, X, hkr> )+ ]->+ [ Out( hkr ),+ !Ephk(~eskR, ~eskR),+ !Sessk( ~eskR, kR) ] /* Key Reveals for the eCK model */ rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]+ [ !Sessk(~tid, k) ] --[ SesskRev(~tid) ]-> [ Out(k) ] rule Ltk_reveal:- [ !Ltk($A, lkA) ]- --[ LtkRev($A) ]->- [ Out(lkA) ]+ [ !Ltk($A, lkA) ] --[ LtkRev($A) ]-> [ Out(lkA) ] rule Ephk_reveal:- [ !Ephk(~ekA) ]- --[ EphkRev(~ekA) ]->- [ Out(~ekA) ]+ [ !Ephk(~s, ~ek) ] --[ EphkRev(~s) ]-> [ Out(~ek) ] /* Security properties */- /*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+lemma eCK_same_key:+ " // If every agent registered at most one public key+ (All A #i #j. RegKey(A)@i & RegKey(A)@j ==> (#i = #j))+ ==> // then matching sessions accept the same key+ (not (Ex #i1 #i2 #i3 #i4 s ss k kk A B minfo .+ Accept(s, A, B, k ) @ i1+ & Accept(ss, B, A, kk) @ i2+ & Sid(s, minfo) @ i3+ & Match(ss, minfo) @i4+ & not( k = kk )+ ) )" */ -/* An attack is valid in eCK if the session key of the test session is deduced and- the test session is clean.-*/-lemma eCK_initiator_key:- "not (Ex #i1 #i2 ekI I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not both longterm-key-reveal _and_ ephemeral-key-reveal- * for test thread. */- & not(Ex #i3 #i4. LtkRev( I ) @ i3 & EphkRev( ekI ) @ i4)-- /* No session-key-reveal of test thread. */- & not(Ex #i3. SesskRev( ekI ) @ i3 )-- /* No session-key-reveal for matching session. */- & not(Ex #i3 #i4 ekR kpartner.- SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( ekR ) @ i4 )-- /* Not both long-term-key-reveal and ephemeral-key-reveal- * for matching session */- & not(Ex #i3 #i4 #i5 ekR kpartner.- SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3- & LtkRev( R ) @ i4- & EphkRev( ekR ) @ i5 )-- /* Longterm-key-reveal of partner only if there is a- * matching session. */- /* (We model eCK-wpfs, for eCK-pfs, add i1 < i3 to conclusion) */- & (All #i3. LtkRev( R ) @ i3 ==>- (* (i1 < i3) | *)- (Ex #i4 ekR kpartner.- SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i4)))"---/* An attack is valid in eCK if the session key of the test session is deduced and- the test session is clean.-*/-lemma eCK_responder_key:- "not (Ex #i1 #i2 ekR I R k hkI hkR.- SidR_1(ekR, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not longterm-key-reveal _and_ ephemeral-key-reveal of actor . */- & not(Ex #i3 #i4. LtkRev( R ) @ i3 & EphkRev( ekR ) @ i4)-- /* Not session-key-reveal of test thread. */- & not(Ex #i3. SesskRev( ekR ) @ i3 )-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & not(Ex #i3 #i4 ekI kpartner.- SidI_2( ekI,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( ekI ) @ i4 )-- /* If there is a partner thread, then not long-term-key-reveal and ephemeral-key-reveal. */- & not(Ex #i3 #i4 #i5 ekI.- SidI_1( ekI,I,R,hkI ) @i3- & LtkRev( I ) @ i4- & EphkRev( ekI ) @ i5 )+lemma eCK_key_secrecy:+ /* + * The property specification very closely follows the original eCK+ * (ProvSec) paper:+ *+ * If there exists a Test session whose key k is known to the+ * Adversary, then...+ */+ "(All #i1 #i2 Test A B k.+ Accept(Test, A, B, k) @ i1 & K( k ) @ i2+ ==> ( + /* ... the Test session must be "not clean".+ * Test is not clean if one of the following has happened:+ */+ /* 1a. session-key-reveal of test thread. */+ (Ex #i3. SesskRev( Test ) @ i3 ) - /* If there is no partner thread, then there is no longterm-key-reveal for- the intended partner.- (We model eCK-wpfs, for eCK-pfs, add i1 < i3 to conclusion)- */- & (All #i3. LtkRev( I ) @ i3 ==>- (* (i1 < i3) | *)- (Ex #i4 ekI.- SidI_1( ekI,I,R,hkI ) @i4)))"+ /* 1b. session-key-reveal of matching session */+ | (Ex MatchingSession #i3 #i4 ms.+ /* ( MatchingSession's 'ms' info matches with Test ) */+ ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4)+ & (+ (Ex #i5. SesskRev( MatchingSession ) @ i5 )+ )+ )+ /* 2. If matching session exists and ... */+ | (Ex MatchingSession #i3 #i4 ms.+ /* ( MatchingSession's 'ms' info matches with Test ) */+ ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4)+ & (+ /* 2a. reveal either both sk_A and esk_A, or */+ (Ex #i5 #i6. LtkRev ( A ) @ i5 & EphkRev ( Test ) @ i6 )+ /* 2b. both sk_B and esk_B */+ | (Ex #i5 #i6. LtkRev ( B ) @ i5 & EphkRev ( MatchingSession ) @ i6 )+ )+ )+ /* 3. No matching session exists and ... */+ | ( ( not(Ex MatchingSession #i3 #i4 ms.+ /* ( MatchingSession's 'ms' info matches with Test ) */+ Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4 ) )+ & (+ /* 3a. reveal either sk_B, or */+ (Ex #i5 . LtkRev (B) @ i5 )+ /* 3b. both sk_A and esk_A */+ | (Ex #i5 #i6. LtkRev (A) @ i5 & EphkRev ( Test ) @ i6 )+ )+ )+ )+ )" end
data/examples/csf12/NAXOS_eCK_PFS.spthy view
@@ -1,20 +1,24 @@ theory NAXOS_eCK_PFS begin -builtin: diffie-hellman, hashing+builtins: diffie-hellman section{* NAXOS *} /* * Protocol: NAXOS * Modeler: Cas Cremers, Benedikt Schmidt- * Date: January 2012+ * Date: January 2012/April 2012 * Source: "Stronger Security of Authenticated Key Exchange" * LaMacchia, Lauter, Mityagin, 2007+ * Property: eCK security with PFS *- * Status: working+ * Status: Working */ +functions: h1/1+functions: h2/1+ /* Protocol rules */ /* In the description in the paper, we omitted the sorts. @@ -25,129 +29,125 @@ /* Generate long-term keypair */ rule generate_ltk:- [ Fr(~lkA) ] -->- [ !Ltk( $A, ~lkA ), !Pk( $A, 'g'^~lkA ), Out( 'g'^~lkA ) ]+ let pkA = 'g'^~lkA + in+ [ Fr(~lkA) ] + --[ RegKey($A) ]->+ [ !Ltk( $A, ~lkA ), !Pk( $A, pkA ), Out( pkA ) ] /* Initiator */-/* To formulate the responder property, we also define a SidI action for- * the first rule. For brevity, we omitted this from the description in- * the paper because there the responder property is not specified. */- rule Init_1:- [ Fr( ~ekI ), !Ltk( $I, ~lkI ) ]- --[ SidI_1(~ekI,$I,$R, 'g'^h(< '1', ~ekI, ~lkI >)) ]->- [ Init_1( ~ekI, $I, $R, ~lkI, 'g'^h(< '1', ~ekI, ~lkI >) ),- !Ephk(~ekI),- Out( 'g'^h(< '1', ~ekI, ~lkI >) ) ]+ let exI = h1(<~eskI, ~lkI >)+ hkI = 'g'^exI+ in+ [ Fr( ~eskI ), !Ltk( $I, ~lkI ) ]+ -->+ [ Init_1( ~eskI, $I, $R, ~lkI, hkI )+ , !Ephk(~eskI, ~eskI)+ , Out( hkI ) ] rule Init_2:- [ Init_1( ~ekI, $I, $R, ~lkI , hkI), In( Y ), !Pk( $R,'g'^~lkR ) ]- --[SidI_2( ~ekI, $I, $R, hkI, Y,- h( < '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI>), Y^h(< '1', ~ekI, ~lkI>), $I, $R> ) ) ]->- [ !Sessk( ~ekI, - h(< '2', Y^~lkI, ('g'^~lkR)^h(< '1', ~ekI, ~lkI> ), Y^h(< '1', ~ekI, ~lkI >), $I, $R>) ) ]+ let pkR = 'g'^~lkR+ exI = h1(< ~eskI, ~lkI >)+ kI = h2(< Y^~lkI, pkR^exI, Y^exI, $I, $R >) + in+ [ Init_1( ~eskI, $I, $R, ~lkI , hkI), !Pk( $R, pkR ), In( Y ) ]+ --[ Accept( ~eskI, $I, $R, kI)+ , Sid( ~eskI, < 'Init', $I, $R, hkI, Y >)+ , Match( ~eskI, < 'Resp', $R, $I, hkI, Y >)+ ]->+ [ !Sessk( ~eskI, kI) ] /* Responder */ rule Resp_1:- [ In( X ), Fr( ~ekR ), !Ltk($R, ~lkR), !Pk($I, 'g'^~lkI) ]- --[ SidR_1( ~ekR, $I, $R, X, 'g'^h( < '1', ~ekR, ~lkR > ),- h(< '2', ('g'^~lkI)^h(< '1', ~ekR, ~lkR >) ,X^~lkR, X^h(< '1', ~ekR, ~lkR >), $I, $R >) ) ]->- [ Out( 'g'^h(<'1', ~ekR, ~lkR >) ),- !Ephk(~ekR),- !Sessk( ~ekR, - h(< '2', ('g'^~lkI)^h(<'1', ~ekR, ~lkR >) ,X^~lkR, X^h(<'1', ~ekR, ~lkR >), $I, $R >) ) ]+ let pkI = 'g'^~lkI+ exR = h1(< ~eskR, ~lkR >)+ hkr = 'g'^exR+ kR = h2(< pkI^exR, X^~lkR, X^exR, $I, $R >) + in+ [ Fr( ~eskR ), !Ltk($R, ~lkR), !Pk($I, pkI), In( X ) ]+ --[ Accept( ~eskR, $R, $I, kR )+ , Sid( ~eskR, <'Resp', $R, $I, X, hkr >)+ , Match( ~eskR, <'Init', $I, $R, X, hkr> )+ ]->+ [ Out( hkr ),+ !Ephk(~eskR, ~eskR),+ !Sessk( ~eskR, kR) ] /* Key Reveals for the eCK model */ rule Sessk_reveal: - [ !Sessk(~tid, k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]+ [ !Sessk(~tid, k) ] --[ SesskRev(~tid) ]-> [ Out(k) ] rule Ltk_reveal:- [ !Ltk($A, lkA) ]- --[ LtkRev($A) ]->- [ Out(lkA) ]+ [ !Ltk($A, lkA) ] --[ LtkRev($A) ]-> [ Out(lkA) ] rule Ephk_reveal:- [ !Ephk(~ekA) ]- --[ EphkRev(~ekA) ]->- [ Out(~ekA) ]+ [ !Ephk(~s, ~ek) ] --[ EphkRev(~s) ]-> [ Out(~ek) ] /* Security properties */- /*-lemma key_agreement_reachable:- "not (Ex #i1 #i2 ekI ekR I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & SidR_1(ekR, I, R, hkI, hkR, k) @ i2)"+lemma eCK_same_key:+ " // If every agent registered at most one public key+ (All A #i #j. RegKey(A)@i & RegKey(A)@j ==> (#i = #j))+ ==> // then matching sessions accept the same key+ (not (Ex #i1 #i2 #i3 #i4 s ss k kk A B minfo .+ Accept(s, A, B, k ) @ i1+ & Accept(ss, B, A, kk) @ i2+ & Sid(s, minfo) @ i3+ & Match(ss, minfo) @i4+ & not( k = kk )+ ) )" */ -/* An attack is valid in eCK if the session key of the test session is deduced and- the test session is clean.-*/-lemma eCK_initiator_key:- "not (Ex #i1 #i2 ekI I R k hkI hkR.- SidI_2(ekI, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not both longterm-key-reveal _and_ ephemeral-key-reveal- * for test thread. */- & not(Ex #i3 #i4. LtkRev( I ) @ i3 & EphkRev( ekI ) @ i4)-- /* No session-key-reveal of test thread. */- & not(Ex #i3. SesskRev( ekI ) @ i3 )-- /* No session-key-reveal for matching session. */- & not(Ex #i3 #i4 ekR kpartner.- SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( ekR ) @ i4 )-- /* Not both long-term-key-reveal and ephemeral-key-reveal- * for matching session */- & not(Ex #i3 #i4 #i5 ekR kpartner.- SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i3- & LtkRev( R ) @ i4- & EphkRev( ekR ) @ i5 )-- /* If there is a longterm key reveal, then it must occur after the initiator is finished- or there must be a matching session- */- & (All #i3. LtkRev( R ) @ i3 ==> - (i1 < i3)- | (Ex #i4 ekR kpartner.- SidR_1( ekR,I,R,hkI,hkR,kpartner ) @i4)))"--/* An attack is valid in eCK if the session key of the test session is deduced and- the test session is clean.-*/-lemma eCK_responder_key:- "not (Ex #i1 #i2 ekR I R k hkI hkR.- SidR_1(ekR, I, R, hkI, hkR, k) @ i1 & K( k ) @ i2-- /* Not longterm-key-reveal _and_ ephemeral-key-reveal of actor . */- & not(Ex #i3 #i4. LtkRev( R ) @ i3 & EphkRev( ekR ) @ i4)-- /* Not session-key-reveal of test thread. */- & not(Ex #i3. SesskRev( ekR ) @ i3 )-- /* Not session-key-reveal of partner thread. Note that we use SidI_2 here.- A session key reveal can only happen after SidI_2 is logged anyways.- */- & not(Ex #i3 #i4 ekI kpartner.- SidI_2( ekI,I,R,hkI,hkR,kpartner ) @i3- & SesskRev( ekI ) @ i4 )-- /* If there is a partner thread, then not long-term-key-reveal and ephemeral-key-reveal. */- & not(Ex #i3 #i4 #i5 ekI.- SidI_1( ekI,I,R,hkI ) @i3- & LtkRev( I ) @ i4- & EphkRev( ekI ) @ i5 )+lemma eCK_PFS_key_secrecy:+ /* + * The property specification very closely follows the original eCK+ * (ProvSec) paper:+ *+ * If there exists a Test session whose key k is known to the+ * Adversary, then...+ */+ "(All #i1 #i2 Test A B k.+ Accept(Test, A, B, k) @ i1 & K( k ) @ i2+ ==> ( + /* ... the Test session must be "not clean".+ * Test is not clean if one of the following has happened:+ */+ /* 1a. session-key-reveal of test thread. */+ (Ex #i3. SesskRev( Test ) @ i3 ) - /* If there is a longterm key reveal, then it must occur after the responder is finished- or there must be a matching session.- */- & (All #i3. LtkRev( I ) @ i3 ==>- (i1 < i3)- | (Ex #i4 ekI.- SidI_1( ekI,I,R,hkI ) @i4)))"+ /* 1b. session-key-reveal of matching session */+ | (Ex MatchingSession #i3 #i4 ms.+ /* ( MatchingSession's 'ms' info matches with Test ) */+ ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4)+ & (+ (Ex #i5. SesskRev( MatchingSession ) @ i5 )+ )+ )+ /* 2. If matching session exists and ... */+ | (Ex MatchingSession #i3 #i4 ms.+ /* ( MatchingSession's 'ms' info matches with Test ) */+ ( Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4)+ & (+ /* 2a. reveal either both sk_A and esk_A, or */+ (Ex #i5 #i6. LtkRev ( A ) @ i5 & EphkRev ( Test ) @ i6 )+ /* 2b. both sk_B and esk_B */+ | (Ex #i5 #i6. LtkRev ( B ) @ i5 & EphkRev ( MatchingSession ) @ i6 )+ )+ )+ /* 3. No matching session exists and ... */+ | ( ( not(Ex MatchingSession #i3 #i4 ms.+ /* ( MatchingSession's 'ms' info matches with Test ) */+ Sid ( MatchingSession, ms ) @ i3 & Match( Test, ms ) @ i4 ) )+ & (+ /* 3a. reveal either sk_B, or */+ (Ex #i5 . LtkRev (B) @ i5 & i5 < i1 ) /* Perfect Forward Secrecy (PFS) modification */+ /* 3b. both sk_A and esk_A */+ | (Ex #i5 #i6. LtkRev (A) @ i5 & EphkRev ( Test ) @ i6 )+ )+ )+ )+ )" end
− data/examples/csf12/STS-MAC-fix1.spthy
@@ -1,123 +0,0 @@-theory STS_MAC_FIX1-begin--builtin: diffie-hellman, hashing, signing--functions: mac/2--section{* The Station-To-Station Protocol (MAC version, fix UKS attack with proof-of-possession of exponent) *}--/*- * Protocol: Station-To-Station, MAC variant: fix with CA Proof-of-Possession check- * Modeler: Cas Cremers- * Date: January 2012- * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol"- * Blake-Wilson, Simon and Menezes, Alfred- * PKC '99, Springer, 1999- *- * Status: working- */--// Public key infrastructure-/**- * The !Pk facts can be regarded as certificates- */-rule Register_pk_normal:- [ Fr(~ltk) ] - --> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ]--// Can register a key, but only if we know the exponent-// Models proof-of-possession check.-rule Register_pk_evil:- [ In(ltk) ] - --[ Corrupt($E) ]-> - [ !Ltk($E, ltk), !Pk($E, pk(ltk)), Out(pk(ltk)) ]--// Protocol-rule Init_1:- [ Fr(~ekI), !Ltk($I, ~ltkI) ]- -->- [ Init_1( $I, $R, ~ltkI, ~ekI )- , Out( <$I, $R, 'g' ^ ~ekI> ) ]--rule Init_2:- [ Init_1( $I, $R, ~ltkI, ~ekI )- , !Pk($R, pk(~ltkR))- , In( <$R, $I, Y, - sign{ Y, 'g'^~ekI }~ltkR,- mac(Y^~ekI,- sign{ Y, 'g'^~ekI }~ltkR- )- > ) ]- --[ AcceptedI(~ekI,$I,$R,'g'^~ekI,Y, h(Y ^ ~ekI)) ]->- [ Out( <$I, $R, - sign{ 'g' ^ ~ekI, Y }~ltkI,- mac( Y^~ekI,- sign{ 'g' ^ ~ekI, Y }~ltkI- )- > ),- !SessionKey(~ekI,$I,$R, h(Y ^ ~ekI))- ]--rule Resp_1:- [ !Ltk($R, ~ltkR)- , Fr(~ekR)- , In( <$I, $R, X > ) ]- -->- [ Resp_1( $I, $R, ~ltkR, ~ekR, X )- , Out( <$R, $I, 'g' ^ ~ekR,- sign{ 'g' ^ ~ekR, X }~ltkR,- mac( X^~ekR,- sign{ 'g' ^ ~ekR, X }~ltkR- )- > ) ]--rule Resp_2:- [ !Pk($I, pk(~ltkI))- , Resp_1( $I, $R, ~ltkR, ~ekR, X )- , In( <$I, $R, - sign{ X, 'g'^~ekR }~ltkI,- mac(X^~ekR,- sign{ X, 'g'^~ekR }~ltkI- )- > ) ]- --[ AcceptedR(~ekR,$I,$R,X,'g'^~ekR, h(X ^ ~ekR)) ]->- [ !SessionKey(~ekR,$I,$R, h(X ^ ~ekR) ) ]--rule Sessionkey_Reveal:- [ !SessionKey(~tid, $I,$R,k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--lemma KI_Perfect_Forward_Secrecy_I:- "not (Ex ttest I R sessKey #i1 #k hki hkr.- AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 &- not (Ex #r. Corrupt(I) @ r) &- not (Ex #r. Corrupt(R) @ r) &- K(sessKey) @ k &- // No session key reveal of test- not (Ex #i3. SesskRev(ttest) @ i3) &- // No session key reveal of partner- not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3- & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4- ) - )- "--lemma KI_Perfect_Forward_Secrecy_R:- "not (Ex ttest I R sessKey #i1 #k hki hkr.- AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 &- not (Ex #r. Corrupt(I) @ r) &- not (Ex #r. Corrupt(R) @ r) &- K(sessKey) @ k &- // No session key reveal of test- not (Ex #i2. SesskRev(ttest) @ i2) &- // No session key reveal of partner- not (Ex #i2 #i3 tpartner kpartner. SesskRev(tpartner) @ i2- & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i3- ) - )- "--end
− data/examples/csf12/STS-MAC-fix2.spthy
@@ -1,122 +0,0 @@-theory STS_MAC_FIX2-begin--builtin: diffie-hellman, hashing, signing--functions: mac/2--section{* The Station-To-Station Protocol (MAC version, fixed with names and tags) *}--/*- * Protocol: Station-To-Station, MAC variant: fix with names and tags inside signatures- * Modeler: Cas Cremers- * Date: January 2012- * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol"- * Blake-Wilson, Simon and Menezes, Alfred- * PKC '99, Springer, 1999- *- * Status: working- */--// Public key infrastructure-/**- * The !Pk facts can be regarded as certificates- *- * Here we model that the adversary might (and in fact always does)- * re-registers the public keys as his own, i.e., he claims a copy of- * the public key for the corrupt name E.- */-rule Register_pk_clone:- [ Fr(~ltk) ] - --[ LtkSet($A, ~ltk), Corrupt($E) ]-> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ]--// Protocol-rule Init_1:- [ Fr(~ekI), !Ltk($I, ~ltkI) ]- -->- [ Init_1( $I, $R, ~ltkI, ~ekI )- , Out( <$I, $R, 'g' ^ ~ekI> ) ]--rule Init_2:- [ Init_1( $I, $R, ~ltkI, ~ekI )- , !Pk($R, pk(~ltkR))- , In( <$R, $I, Y, - sign{ '1', $I, $R, Y, 'g'^~ekI }~ltkR,- mac(Y^~ekI,- sign{ '1', $I, $R, Y, 'g'^~ekI }~ltkR- )- > ) ]- --[ AcceptedI(~ekI,$I,$R,'g'^~ekI,Y, h(Y ^ ~ekI) ) ]->- [ Out( <$I, $R, - sign{ '2', $I, $R, 'g' ^ ~ekI, Y }~ltkI,- mac( Y^~ekI,- sign{ '2', $I, $R, 'g' ^ ~ekI, Y }~ltkI- )- > ),- !SessionKey(~ekI,$I,$R, h(Y ^ ~ekI))- ]--rule Resp_1:- [ !Ltk($R, ~ltkR)- , Fr(~ekR)- , In( <$I, $R, X > ) ]- -->- [ Resp_1( $I, $R, ~ltkR, ~ekR, X )- , Out( <$R, $I, 'g' ^ ~ekR,- sign{ '1', $I, $R, 'g' ^ ~ekR, X }~ltkR,- mac( X^~ekR,- sign{ '1', $I, $R, 'g' ^ ~ekR, X }~ltkR- )- > ) ]--rule Resp_2:- [ !Pk($I, pk(~ltkI))- , Resp_1( $I, $R, ~ltkR, ~ekR, X )- , In( <$I, $R, - sign{ '2', $I, $R, X, 'g'^~ekR }~ltkI,- mac(X^~ekR,- sign{ '2', $I, $R, X, 'g'^~ekR }~ltkI- )- > ) ]- --[ AcceptedR(~ekR,$I,$R,X,'g'^~ekR, h(X ^ ~ekR) ) ]->- [ !SessionKey(~ekR,$I,$R, h(X ^ ~ekR) ) ]--rule Sessionkey_Reveal:- [ !SessionKey(~tid, $I,$R,k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--lemma KI_Perfect_Forward_Secrecy_I:- "not (Ex ttest I R sessKey #i1 #k hki hkr.- AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 &- not (Ex #r. Corrupt(I) @ r) &- not (Ex #r. Corrupt(R) @ r) &- K(sessKey) @ k &- // No session key reveal of test- not (Ex #i3. SesskRev(ttest) @ i3) &- // No session key reveal of partner- not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3- & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4- )- )- "--lemma KI_Perfect_Forward_Secrecy_R:- "not (Ex ttest I R sessKey #i1 #k hki hkr.- AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 &- not (Ex #r. Corrupt(I) @ r) &- not (Ex #r. Corrupt(R) @ r) &- K(sessKey) @ k &- // No session key reveal of test- not (Ex #i3. SesskRev(ttest) @ i3) &- // No session key reveal of partner- not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3- & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4- ) - )- "----end
− data/examples/csf12/STS-MAC.spthy
@@ -1,122 +0,0 @@-theory STS_MAC-begin--builtin: diffie-hellman, hashing, signing--functions: mac/2--section{* The Station-To-Station Protocol (MAC version) *}--/*- * Protocol: Station-To-Station, MAC variant- * Modeler: Cas Cremers- * Date: January 2012- * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol"- * Blake-Wilson, Simon and Menezes, Alfred- * PKC '99, Springer, 1999- *- * Status: working- */--// Public key infrastructure-/**- * The !Pk facts can be regarded as certificates- *- * Here we model that the adversary might (and in fact always does)- * re-registers the public keys as his own, i.e., he claims a copy of- * the public key for the corrupt name E.- */-rule Register_pk_clone:- [ Fr(~ltk) ] - --[ LtkSet($A, ~ltk), Corrupt($E) ]-> - [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ]--// Protocol-rule Init_1:- [ Fr(~ekI), !Ltk($I, ~ltkI) ]- -->- [ Init_1( $I, $R, ~ltkI, ~ekI )- , Out( <$I, $R, 'g' ^ ~ekI> ) ]--rule Init_2:- [ Init_1( $I, $R, ~ltkI, ~ekI )- , !Pk($R, pk(~ltkR))- , In( <$R, $I, Y, - sign{ Y, 'g'^~ekI }~ltkR,- mac(Y^~ekI,- sign{ Y, 'g'^~ekI }~ltkR- )- > ) ]- --[ AcceptedI(~ekI,$I,$R,'g'^~ekI,Y, h(Y ^ ~ekI) ) ]->- [ Out( <$I, $R, - sign{ 'g' ^ ~ekI, Y }~ltkI,- mac( Y^~ekI,- sign{ 'g' ^ ~ekI, Y }~ltkI- )- > ),- !SessionKey(~ekI,$I,$R, h(Y ^ ~ekI))- ]--rule Resp_1:- [ !Ltk($R, ~ltkR)- , Fr(~ekR)- , In( <$I, $R, X > ) ]- -->- [ Resp_1( $I, $R, ~ltkR, ~ekR, X )- , Out( <$R, $I, 'g' ^ ~ekR,- sign{ 'g' ^ ~ekR, X }~ltkR,- mac( X^~ekR,- sign{ 'g' ^ ~ekR, X }~ltkR- )- > ) ]--rule Resp_2:- [ !Pk($I, pk(~ltkI))- , Resp_1( $I, $R, ~ltkR, ~ekR, X )- , In( <$I, $R, - sign{ X, 'g'^~ekR }~ltkI,- mac(X^~ekR,- sign{ X, 'g'^~ekR }~ltkI- )- > ) ]- --[ AcceptedR(~ekR,$I,$R,X,'g'^~ekR, h(X ^ ~ekR) ) ]->- [ !SessionKey(~ekR,$I,$R, h(X ^ ~ekR) ) ]--rule Sessionkey_Reveal:- [ !SessionKey(~tid, $I,$R,k) ]- --[ SesskRev(~tid) ]->- [ Out(k) ]--lemma KI_Perfect_Forward_Secrecy_I:- "not (Ex ttest I R sessKey #i1 #k hki hkr.- AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 &- not (Ex #r. Corrupt(I) @ r) &- not (Ex #r. Corrupt(R) @ r) &- K(sessKey) @ k &- // No session key reveal of test- not (Ex #i3. SesskRev(ttest) @ i3) &- // No session key reveal of partner- not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3- & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4- ) - )- "--lemma KI_Perfect_Forward_Secrecy_R:- "not (Ex ttest I R sessKey #i1 #k hki hkr.- AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 &- not (Ex #r. Corrupt(I) @ r) &- not (Ex #r. Corrupt(R) @ r) &- K(sessKey) @ k &- // No session key reveal of test- not (Ex #i3. SesskRev(ttest) @ i3) &- // No session key reveal of partner- not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3- & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4- ) - )- "----end
+ data/examples/csf12/STS_MAC.spthy view
@@ -0,0 +1,129 @@+theory STS_MAC+begin++builtins: diffie-hellman, hashing, signing++functions: mac/2+functions: KDF/1++section{* The Station-To-Station Protocol (MAC version) *}++/*+ * Protocol: Station-To-Station, MAC variant+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol"+ * Blake-Wilson, Simon and Menezes, Alfred+ * PKC '99, Springer, 1999+ *+ * Status: working+ */++// Public key infrastructure+/**+ * The !Pk facts can be regarded as certificates+ *+ * Here we model that the adversary might (and in fact always does)+ * re-registers the public keys as his own, i.e., he claims a copy of+ * the public key for the corrupt name E.+ */+rule Register_pk_clone:+ [ Fr(~ltk) ] + --[ LtkSet($A, ~ltk), Corrupt($E) ]-> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ]++// Protocol+rule Init_1:+ let epkI = 'g'^~ekI+ in+ [ Fr(~ekI), !Ltk($I, ~ltkI) ]+ -->+ [ Init_1( $I, $R, ~ltkI, ~ekI )+ , Out( <$I, $R, epkI> ) ]++rule Init_2:+ let epkI = 'g'^~ekI+ sigI = sign{ epkI, Y }~ltkI+ sigR = sign{ Y, epkI }~ltkR+ keymat = Y^~ekI+ key = KDF(keymat)+ in+ [ Init_1( $I, $R, ~ltkI, ~ekI )+ , !Pk($R, pk(~ltkR))+ , In( <$R, $I, Y, sigR, mac( keymat, sigR)+ > ) ]+ --[ AcceptedI(~ekI,$I,$R,epkI,Y, key) ]->+ [ Out( <$I, $R, sigI, mac( keymat, sigI) > ),+ !SessionKey(~ekI,$I,$R, key)+ ]++rule Resp_1:+ let epkR = 'g'^~ekR+ sigI = sign{ X, epkR }~ltkI+ sigR = sign{ epkR, X }~ltkR+ keymat = X^~ekR+ key = KDF(keymat)+ in+ [ !Ltk($R, ~ltkR)+ , Fr(~ekR)+ , In( <$I, $R, X > ) ]+ -->+ [ Resp_1( $I, $R, ~ltkR, ~ekR, X )+ , Out(< $R, $I, epkR, sigR, mac( keymat, sigR ) >) + ]+++rule Resp_2:+ let epkR = 'g'^~ekR+ sigI = sign{ X, epkR }~ltkI+ sigR = sign{ epkR, X }~ltkR+ keymat = X^~ekR+ key = KDF(keymat)+ in+ [ !Pk($I, pk(~ltkI))+ , Resp_1( $I, $R, ~ltkR, ~ekR, X )+ , In( <$I, $R, sigI, mac( keymat, sigI ) >)+ ]+ --[ AcceptedR(~ekR,$I,$R,X,epkR, key ) ]->+ [ !SessionKey(~ekR,$I,$R, key) ]++++rule Sessionkey_Reveal:+ [ !SessionKey(~tid, $I,$R,k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++lemma KI_Perfect_Forward_Secrecy_I:+ "not (Ex ttest I R sessKey #i1 #k hki hkr.+ AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 &+ not (Ex #r. Corrupt(I) @ r) &+ not (Ex #r. Corrupt(R) @ r) &+ K(sessKey) @ k &+ // No session key reveal of test+ not (Ex #i3. SesskRev(ttest) @ i3) &+ // No session key reveal of partner+ not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3+ & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4+ ) + )+ "++lemma KI_Perfect_Forward_Secrecy_R:+ "not (Ex ttest I R sessKey #i1 #k hki hkr.+ AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 &+ not (Ex #r. Corrupt(I) @ r) &+ not (Ex #r. Corrupt(R) @ r) &+ K(sessKey) @ k &+ // No session key reveal of test+ not (Ex #i3. SesskRev(ttest) @ i3) &+ // No session key reveal of partner+ not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3+ & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4+ ) + )+ "++++end
+ data/examples/csf12/STS_MAC_fix1.spthy view
@@ -0,0 +1,132 @@+theory STS_MAC_fix1+begin++builtins: diffie-hellman, signing++functions: mac/2+functions: KDF/1++section{* The Station-To-Station Protocol (MAC version, fix UKS attack with proof-of-possession of exponent) *}++/*+ * Protocol: Station-To-Station, MAC variant: fix with CA Proof-of-Possession check+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol"+ * Blake-Wilson, Simon and Menezes, Alfred+ * PKC '99, Springer, 1999+ *+ * Status: working+ */++// Public keymat infrastructure+/**+ * The !Pk facts can be regarded as certificates+ */+rule Register_pk_normal:+ [ Fr(~ltk) ] + --> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), Out(pk(~ltk)) ]++// Can register a key, but only if we know the exponent+// Models proof-of-possession check.+rule Register_pk_evil:+ [ In(ltk) ] + --[ Corrupt($E) ]-> + [ !Ltk($E, ltk), !Pk($E, pk(ltk)), Out(pk(ltk)) ]++// Protocol+rule Init_1:+ let epkI = 'g'^~ekI+ in+ [ Fr(~ekI), !Ltk($I, ~ltkI) ]+ -->+ [ Init_1( $I, $R, ~ltkI, ~ekI )+ , Out( <$I, $R, epkI> ) ]++rule Init_2:+ let epkI = 'g'^~ekI+ sigI = sign{ epkI, Y }~ltkI+ sigR = sign{ Y, epkI }~ltkR+ keymat = Y^~ekI+ key = KDF(keymat)+ in+ [ Init_1( $I, $R, ~ltkI, ~ekI )+ , !Pk($R, pk(~ltkR))+ , In( <$R, $I, Y, sigR, mac( keymat, sigR)+ > ) ]+ --[ AcceptedI(~ekI,$I,$R,epkI,Y, key) ]->+ [ Out( <$I, $R, sigI, mac( keymat, sigI) > ),+ !SessionKey(~ekI,$I,$R, key)+ ]++rule Resp_1:+ let epkR = 'g'^~ekR+ sigI = sign{ X, epkR }~ltkI+ sigR = sign{ epkR, X }~ltkR+ keymat = X^~ekR+ key = KDF(keymat)+ in+ [ !Ltk($R, ~ltkR)+ , Fr(~ekR)+ , In( <$I, $R, X > ) ]+ -->+ [ Resp_1( $I, $R, ~ltkR, ~ekR, X )+ , Out(< $R, $I, epkR, sigR, mac( keymat, sigR ) >) + ]+++rule Resp_2:+ let epkR = 'g'^~ekR+ sigI = sign{ X, epkR }~ltkI+ sigR = sign{ epkR, X }~ltkR+ keymat = X^~ekR+ key = KDF(keymat)+ in+ [ !Pk($I, pk(~ltkI))+ , Resp_1( $I, $R, ~ltkR, ~ekR, X )+ , In( <$I, $R, sigI, mac( keymat, sigI ) >)+ ]+ --[ AcceptedR(~ekR,$I,$R,X,epkR, key ) ]->+ [ !SessionKey(~ekR,$I,$R, key) ]++++rule Sessionkey_Reveal:+ [ !SessionKey(~tid, $I,$R,k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++++lemma KI_Perfect_Forward_Secrecy_I:+ "not (Ex ttest I R sessKey #i1 #k hki hkr.+ AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 &+ not (Ex #r. Corrupt(I) @ r) &+ not (Ex #r. Corrupt(R) @ r) &+ K(sessKey) @ k &+ // No session keymat reveal of test+ not (Ex #i3. SesskRev(ttest) @ i3) &+ // No session keymat reveal of partner+ not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3+ & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4+ ) + )+ "++lemma KI_Perfect_Forward_Secrecy_R:+ "not (Ex ttest I R sessKey #i1 #k hki hkr.+ AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 &+ not (Ex #r. Corrupt(I) @ r) &+ not (Ex #r. Corrupt(R) @ r) &+ K(sessKey) @ k &+ // No session keymat reveal of test+ not (Ex #i2. SesskRev(ttest) @ i2) &+ // No session keymat reveal of partner+ not (Ex #i2 #i3 tpartner kpartner. SesskRev(tpartner) @ i2+ & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i3+ ) + )+ "++end
+ data/examples/csf12/STS_MAC_fix2.spthy view
@@ -0,0 +1,129 @@+theory STS_MAC_fix2+begin++builtins: diffie-hellman, hashing, signing++functions: mac/2+functions: KDF/1++section{* The Station-To-Station Protocol (MAC version, fixed with names and tags) *}++/*+ * Protocol: Station-To-Station, MAC variant: fix with names and tags inside signatures+ * Modeler: Cas Cremers+ * Date: January 2012+ * Source: "Unknown Key-Share Attacks on the Station-to-Station (STS) Protocol"+ * Blake-Wilson, Simon and Menezes, Alfred+ * PKC '99, Springer, 1999+ *+ * Status: working+ */++// Public key infrastructure+/**+ * The !Pk facts can be regarded as certificates+ *+ * Here we model that the adversary might (and in fact always does)+ * re-registers the public keys as his own, i.e., he claims a copy of+ * the public key for the corrupt name E.+ */+rule Register_pk_clone:+ [ Fr(~ltk) ] + --[ LtkSet($A, ~ltk), Corrupt($E) ]-> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)), !Pk($E, pk(~ltk)), Out(pk(~ltk)) ]++// Protocol+rule Init_1:+ let epkI = 'g'^~ekI+ in+ [ Fr(~ekI), !Ltk($I, ~ltkI) ]+ -->+ [ Init_1( $I, $R, ~ltkI, ~ekI )+ , Out( <$I, $R, epkI> ) ]++rule Init_2:+ let epkI = 'g'^~ekI+ sigI = sign{ '2', $I, $R, epkI, Y }~ltkI+ sigR = sign{ '1', $I, $R, Y, epkI }~ltkR+ keymat = Y^~ekI+ key = KDF(keymat)+ in+ [ Init_1( $I, $R, ~ltkI, ~ekI )+ , !Pk($R, pk(~ltkR))+ , In( <$R, $I, Y, sigR, mac( keymat, sigR)+ > ) ]+ --[ AcceptedI(~ekI,$I,$R,epkI,Y, key) ]->+ [ Out( <$I, $R, sigI, mac( keymat, sigI) > ),+ !SessionKey(~ekI,$I,$R, key)+ ]++rule Resp_1:+ let epkR = 'g'^~ekR+ sigI = sign{ '2', $I, $R, X, epkR }~ltkI+ sigR = sign{ '1', $I, $R, epkR, X }~ltkR+ keymat = X^~ekR+ key = KDF(keymat)+ in+ [ !Ltk($R, ~ltkR)+ , Fr(~ekR)+ , In( <$I, $R, X > ) ]+ -->+ [ Resp_1( $I, $R, ~ltkR, ~ekR, X )+ , Out(< $R, $I, epkR, sigR, mac( keymat, sigR ) >) + ]+++rule Resp_2:+ let epkR = 'g'^~ekR+ sigI = sign{ '2', $I, $R, X, epkR }~ltkI+ sigR = sign{ '1', $I, $R, epkR, X }~ltkR+ keymat = X^~ekR+ key = KDF(keymat)+ in+ [ !Pk($I, pk(~ltkI))+ , Resp_1( $I, $R, ~ltkR, ~ekR, X )+ , In( <$I, $R, sigI, mac( keymat, sigI ) >)+ ]+ --[ AcceptedR(~ekR,$I,$R,X,epkR, key ) ]->+ [ !SessionKey(~ekR,$I,$R, key) ]++++rule Sessionkey_Reveal:+ [ !SessionKey(~tid, $I,$R,k) ]+ --[ SesskRev(~tid) ]->+ [ Out(k) ]++lemma KI_Perfect_Forward_Secrecy_I:+ "not (Ex ttest I R sessKey #i1 #k hki hkr.+ AcceptedI(ttest,I,R,hki,hkr,sessKey) @ i1 &+ not (Ex #r. Corrupt(I) @ r) &+ not (Ex #r. Corrupt(R) @ r) &+ K(sessKey) @ k &+ // No session key reveal of test+ not (Ex #i3. SesskRev(ttest) @ i3) &+ // No session key reveal of partner+ not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3+ & AcceptedR(tpartner,I,R,hki,hkr,kpartner) @ i4+ )+ )+ "++lemma KI_Perfect_Forward_Secrecy_R:+ "not (Ex ttest I R sessKey #i1 #k hki hkr.+ AcceptedR(ttest,I,R,hki,hkr,sessKey) @ i1 &+ not (Ex #r. Corrupt(I) @ r) &+ not (Ex #r. Corrupt(R) @ r) &+ K(sessKey) @ k &+ // No session key reveal of test+ not (Ex #i3. SesskRev(ttest) @ i3) &+ // No session key reveal of partner+ not (Ex #i3 #i4 tpartner kpartner. SesskRev(tpartner) @ i3+ & AcceptedI(tpartner,I,R,hki,hkr,kpartner) @ i4+ ) + )+ "++++end
data/examples/csf12/SignedDH_PFS.spthy view
@@ -1,4 +1,4 @@-theory SignedDH+theory SignedDH_PFS begin section{* The Signed Diffie-Hellman Protocol *}@@ -11,7 +11,7 @@ * Status: working */ -builtin: diffie-hellman, signing+builtins: diffie-hellman, signing // Public key infrastructure rule Register_pk:
data/examples/csf12/SignedDH_eCK.spthy view
@@ -1,7 +1,7 @@ theory SignedDH_eCK begin -builtin: diffie-hellman, signing+builtins: diffie-hellman, signing section{* The Signed Diffie-Hellman Protocol in the eCK model *}
data/examples/csf12/UM_PFS.spthy view
@@ -1,7 +1,7 @@ theory UM_PFS begin -builtin: hashing, diffie-hellman+builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *}
data/examples/csf12/UM_eCK.spthy view
@@ -1,7 +1,7 @@ theory UM_eCK begin -builtin: hashing, diffie-hellman+builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *}
data/examples/csf12/UM_eCK_noKCI.spthy view
@@ -1,7 +1,7 @@ theory UM_eCK_noKCI begin -builtin: hashing, diffie-hellman+builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *}
data/examples/csf12/UM_wPFS.spthy view
@@ -1,7 +1,7 @@ theory UM_wPFS begin -builtin: hashing, diffie-hellman+builtins: hashing, diffie-hellman section{* The Unified Model (UM) Key-Exchange Protocol *}
+ data/examples/stable/InvariantsExample.spthy view
@@ -0,0 +1,69 @@+theory InvariantsExample +begin + +builtins: symmetric-encryption + +/* + * Protocol: Minimal example of handle-based crypto + * Modeler: Simon Meier + * Date: April 2012 + * + * Status: working + + This example demonstrates the verification problem that we face when + reasoning about handle-based cryptography. The protocol is simple. It models + a crypto coprocessor that can generate new keys, use them to encrypt data, + and wrap keys with other stored keys. + + */ + + +/* Generate a fresh handle and a fresh key, store their association, and + * output the handle */ +rule NewKey: + [ Fr(~h), Fr(~k) ] + --[ NewKey(~h,~k) ]-> + [ !Store(~h,~k) , Out(~h) ] + +/* Encrypt a message using a key referenced by a handle */ +rule EncryptMsg: + [ !Store(h,k), In(<h, m>)] + --> + [ Out( senc{m}k ) ] + +/* Wrap a key reference by a handle using another key referenced by a second + * handle */ +rule WrapKey: + [ !Store(h1,k1), !Store(h2,k2), In(<h1,h2>)] + --> + [ Out( senc{k1}k2 ) ] + + +/* The 'reuse' attribute marks this property such that it should be used in + * proof of later theorems. This is what we'd like to do with such a property + * which proves that no created key can be deduced by the adversary. The + * 'invariant' attribute denotes that this property is an inductive invariant + * of normal dependency graphs. This instructs Tamarin to use induction as the + * first proof step. + * + * Note that construction of using 'Ded'-facts to log the conclusions of + * construction rules is work in progress. Tamarin is missing some constraint + * reduction rules to infer the presence of 'Ded'-facts in all cases. + * Moreover, it might also miss some rules to deal with the 'Last(i)' atoms, + * which states that 'i' is the last index in the trace that is annotated with + * an action. + * + * Tamarin can prove this property automatically. + */ +lemma NewKey_invariant [reuse, invariant]: + "not(Ex #i #j h k. NewKey(h, k) @ i & Ded(k) @ j) " + +/* This property talks only about standard traces that do not refer to the + * actions of construction rules. It can be proven thanks to the + * NewKey_invariant proven before. Try an interactive proof after removing the + * 'reuse' flag above to see what goes wrong without induction and the 'Ded' + * facts. */ +lemma NewKey_secrecy: + "not(Ex #i #j h k. NewKey(h, k) @ i & K(k) @ j) " + +end
+ data/examples/stable/TLS.spthy view
@@ -0,0 +1,188 @@+theory TLS +begin++builtins: hashing, symmetric-encryption, asymmetric-encryption, signing++section{* TLS Handshake *}++/*+ * Protocol: TLS Handshake+ * Modeler: Simon Meier, minor update by Cas Cremers+ * Date: January 2012+ * Source: Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy.+ *+ * Status: working (2.5 seconds on an i7 Quad-Core CPU with +RTS -N)+ */++text{*+ Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy. Notable+ differences are:++ 1. We use explicit global constants to differentiate between different+ encryptions instead of implicit typing.++ 2. We model session keys directly as hashes of the relevant information.+ Due to our support for composed keys, we do not need any custom+ axiomatization as Paulson does.++*}++functions: PRF/1++// Public key infrastructure+rule Register_pk:+ [ Fr(~ltkA) ] + --> + [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ]++rule Reveal_ltk:+ [ !Ltk(A, ltkA) ] --[ RevLtk(A) ]-> [ Out(ltkA) ]+++/* We formalize the following signature based TLS handshake.++ protocol TLS {+ 1. C -> S: C, nc, sid, pc+ 2. C <- S: ns, sid, ps++ 3. C -> S: { '31', pms }pk(S) ,+ sign{ '32', h('32', ns, S, pms) }pk(C) ,+ { '33', sid, PRF(pms, nc, ns),+ nc, pc, C, ns, ps, S+ } + h('clientKey', nc, ns, PRF(pms, nc, ns))++ 4. C <- S: { '4', sid, PRF(pms, nc, ns),+ nc, pc, C, ns, ps, S+ } + h('serverKey', nc, ns, PRF(pms, nc, ns))+ }+*/++rule C_1:+ [ Fr(~nc)+ , Fr(~sid)+ ]+ --[]->+ [ Out(+ <$C, ~nc, ~sid, $pc>+ )+ , St_C_1($C, ~nc, ~sid, $pc)+ ]++rule S_1:+ [ In( + <$C, nc, sid, pc>+ )+ , Fr(~ns)+ ]+ --[]->+ [ Out(+ <$S, ~ns, sid, $ps>+ )+ , St_S_1($S, $C, sid, nc, pc, ~ns, $ps)+ ]++rule C_2:+ let + MS = PRF(~pms, nc, ns)+ Ckey = h('clientKey', nc, ns, MS)+ in + [ St_C_1(C, nc, sid, pc)+ , In(+ <S, ns, sid, ps>+ )+ , Fr(~pms)+ , !Pk(S, pkS)+ , !Ltk(C, ltkC)+ ]+ --[]->+ [ Out(+ < aenc{ '31', ~pms }pkS+ , sign{ '32', h('32', ns, S, ~pms) }ltkC+ , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey+ >+ )+ , St_C_2(S, C, sid, nc, pc, ns, ps, ~pms)+ ]++rule S_2:+ let + MS = PRF(pms, nc, ns)+ Ckey = h('clientKey', nc, ns, MS)+ Skey = h('serverKey', nc, ns, MS)+ in + [ St_S_1(S, C, sid, nc, pc, ns, ps)+ , In(+ < aenc{ '31', pms }pk(ltkS)+ , signature+ , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey+ >+ )+ , !Pk(C, pkC)+ , !Ltk(S, ltkS)+ ]+ /* Explicit equality check, enforced as part of the property. */+ --[ Eq(verify(signature, <'32', h('32', ns, S, pms)>, pkC), true )+ , SessionKeys( S, C, Skey, Ckey )+ ]->+ [ Out(+ senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey+ )+ ]++rule C_3:+ let + MS = PRF(pms, nc, ns)+ Ckey = h('clientKey', nc, ns, MS)+ Skey = h('serverKey', nc, ns, MS)+ in + [ St_C_2(S, C, sid, nc, pc, ns, ps, pms)+ , In( senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey )+ ]+ --[ SessionKeys( S, C, Skey, Ckey ) ]->+ []+++/* TODO: Also model session-key reveals and adapt security properties. */+++/* Session key secrecy from the perspecitive of both the server and the client+ * for both the key of the server and the key of the client. Note that this+ * lemma thus captures four security properties at once. */+lemma session_key_secrecy:+ " /* If all equality checks succeeded */+ (All x y #i. Eq(x,y) @ i ==> x = y)+ ==>+ /* then there is no attack */ + (not( + /* It cannot be that */+ Ex S C keyS keyC #k.+ /* somebody claims to have setup session keys, */+ SessionKeys(S, C, keyS, keyC) @ k + /* but the adversary knows one of them */+ & ( (Ex #i. K(keyS) @ i) + | (Ex #i. K(keyC) @ i)+ )+ /* without having performed a long-term key reveal. */+ & not (Ex #r. RevLtk(S) @ r)+ & not (Ex #r. RevLtk(C) @ r)+ ) )"++/* Consistency check: this lemma must NOT have a proof,+ * as otherwise no session-keys could be setup between honest agents. */+lemma session_key_setup_possible:+ exists-trace+ " /* There is a trace satisfying all equality checks */+ (All x y #i. Eq(x,y) @ i ==> x = y)+ & /* Session keys have been setup */+ (Ex S C keyS keyC #k. SessionKeys(S, C, keyS, keyC) @ k + /* without having performed a long-term key reveal. */+ & not (Ex #r. RevLtk(S) @ r)+ & not (Ex #r. RevLtk(C) @ r)+ )+ "+++end+
+ data/examples/stable/Tutorial.spthy view
@@ -0,0 +1,403 @@+/*+Tutorial for the Tamarin prover for security protocol analysis+==============================================================++Authors: Simon Meier, Benedikt Schmidt+Date: April 2012+++Introduction+------------++This user guide assumes that you have a copy of our CSF'12 paper on+"Automated Analysis of Diffie-Hellman Protocols and Advanced Security+Properties", whose extended version is available from+http://www.infsec.ethz.ch/research/software#TAMARIN.++The input files for the Tamarin prover have the extension .spthy, which is+short for 'security protocol theory'. A security protocol theory specifies++ 1. the signature and equational theory to use for the message algebra,+ 2. the set of set of multiset rewriting rules modeling the protocol and+ the adversary capabilities, and+ 3. the guarded trace properties whose validity we wish to check for this+ set of multiset rewriting rules.++We explain each of these parts where they occur in the following security+protocol theory. Before we start, a few notes on the syntax.+As you probably noticed, comments are C-style. All identifiers are+case-sensitive. The parser is layout-insensitive, i.e., your are free to use+whitespace as it suits you. We provide a complete specification of the input+syntax in the reference MANUAL.+++Modeling a security protocol+----------------------------++Every security protocol theory starts with a header of the following form.+*/++theory Tutorial+begin++/*+Obviously, you can replace 'Tutorial' with any name you like to give your+theory. After 'begin', you can declare function symbols, equations that they+must satisfy, multiset rewriting rules, and lemmas specifying security+properties. Moreover, you can also insert formal comments, to structure your+theory. We give examples of each of these elements while modeling the+a simple protocol. ++In this protocol, a client C generates a fresh symmetric key 'k', encrypts it+with the public key of a server 'S' and sends it to 'S'. The server confirms+the receipt of the key by sending back its hash to the client. In+Alice-and-Bob notation the protocol would read as follows.++ C -> S: aenc{k}pk(S)+ C <- S: h(k)++This protocol is artificial and it satisfies only very weak security+guarantees. We can prove that from the perspective of the client, the freshly+generated key is secret provided that the server is uncompromised.++We model this protocol in three steps. First, we declare the function symbols+and the equations defining them. Then, we introduce multiset rewriting rules+modeling a public key infrastructure (PKI) and the protocol. Finally, we state+the expected security properties.+++Function Signature and Equational Theory+----------------------------------------++We model hashing using the unary function 'h'.+We model asymmetric encryption by declaring + a binary function 'aenc' denoting the encryption algorithm,+ a binary function 'adec' denoting the decryption algorithm, and+ a unary function 'pk' denoting the algorithm computing a public+ key from a private key.+*/++functions: h/1, aenc/2, adec/2, pk/1+equations: adec(aenc(m, pk(k)), k) = m++/*+The above equation models the interaction between calls to these three+algorithms. All such user-specified equations must be subterm-convergent+rewriting rules, when oriented from left to right. This means that the+right-hand-side must be a subterm of the left-hand-side or a nullary+function symbol.++Certain equational theories are used very often when modeling cryptographic+messages. We therefore provide builtins definitions for them. The above theory+could also be enabled using the declaration++ builtins: hashing, asymmetric-encryption++We support the following builtins theories:+ + diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,+ hashing++Note that the theory for hashing only introduces the function symbol 'h/1'+and contains no equations.+Apart from 'diffie-hellman', all of these theories are subterm-convergent and+can therefore also be declared directly, as above. You can inspect their+definitions by uncommenting the following two line-comments and calling++ tamarin-prover Tutorial.spthy++*/++// builtins: diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,+// hashing++/*+The call 'tamarin-prover Tutorial.spthy' parses the Tutorial.spthy file,+computes the variants of the multiset rewriting rules, checks their+wellformedness (explained below), and pretty-prints the theory. The+declaration of the signature and the equations can be found at the top of the+pretty-printed theory.++Proving all lemmas contained in the theory is as simple as adding the+flag '--prove' to the call; i.e.,++ tamarin-prover Tutorial.spthy --prove++However, let's not go there yet. We first have to model the PKI and our+protocol.+++Modeling the Public Key Infrastructure+--------------------------------------+*/++// Registering a public key+rule Register_pk:+ [ Fr(~ltk) ] + --> + [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)) ]++/* The above rule models registering a public key. It makes use of the+ following syntax.+ + Facts always start with an upper-case letter and do not have to declared.+ If their name is prefixed with an exclamation mark '!', then they are+ persistent. Otherwise, they are linear. Note that you must use every fact+ name consistently; i.e., you must always use it with the same arity, casing,+ and multiplicity. Otherwise, the tamarin prover complains that the theory+ is not wellformed.++ The 'Fr' fact is a builtins fact. It denotes a freshly generated fresh name.+ See the paper for details.++ We denote the sort of variables using prefixes:++ ~x denotes x:fresh+ $x denotes x:pub+ #i denotes i:temp+ i denotes i:msg++ 'c' denotes a public name 'c \in PN'; i.e., a fixed, global constant+ + Thus, the above rule can be read as follows. First, freshly generate a+ fresh name 'ltk', the new private key and nondeterministically choose a+ public name 'A', the agent for which we are generating the key-pair.+ Then, generate the persistent fact !Ltk($A, ~ltk), which denotes the+ association between agent 'A' and its private key 'ltk, and generate the+ persistent fact !Pk($A, pk(~ltk)), which denotes the association between the+ agent 'A' and its public key 'pk(~ltk)'.++ We allow the adversary to retrieve any public key using the following rule.+ Intuitively, it just reads a public-key database entry and sends the public+ key to the network using the builtins fact 'Out' denoting a message sent to+ the network. See our paper for more information.+*/++rule Get_pk:+ [ !Pk(A, pk) ] + --> + [ Out(pk) ]++/*+ We model the dynamic compromise of long-term private keys using the following+ rule. Intuitively, it reads a private-key database entry and sends it to+ the adversary. This rule has an observable 'LtkReveal' action stating that+ the long-term key of agent 'A' was compromised. We will use this action in+ the security property below to determine which agents are compromised.+*/++rule Reveal_ltk:+ [ !Ltk(A, ltk) ]+ --[ LtkReveal(A) ]->+ [ Out(ltk) ]+++/*++Modeling the protocol+----------------------++Recall that we want to model the following protocol.++ C -> S: aenc{k}pk(S)+ C <- S: h(k)++We model it use the following three rules.+*/++// Start a new thread executing the client role, choosing the server+// non-deterministically.+rule Client_1:+ [ Fr(~k) // choose fresh key+ , !Pk($S, pkS) // lookup public-key of server+ ]+ -->+ [ Client_1( $S, ~k ) // Store server and key for next step of thread+ , Out( aenc{'1', ~k}pkS ) // Send the encrypted session key to the server+ // We add the tag '1' to the request to allow+ // the server to check whether the decryption+ // was successful.+ ]++rule Client_2:+ [ Client_1(S, k) // Retrieve server and session key from previous step+ , In( h(k) ) // Receive hashed session key from network+ ]+ --[ SessKeyC( S, k ) ]-> // State that the session key 'k'+ [] // was setup with server 'S'++// A server thread answering in one-step to a session-key setup request from+// some client.+rule Serv_1:+ [ !Ltk($S, ~ltkS) // lookup the private-key+ , In( request ) // receive a request+ ]+ --[ Eq(fst(adec(request, ~ltkS)), '1')+ , AnswerRequest($S, snd(adec(request, ~ltkS))) // Explanation below+ ]-> + [ Out( h(snd(adec(request, ~ltkS))) ) ] // Return the hash of the+ // decrypted request.++/* Above, we model all applications of cryptographic algorithms explicitly.+ Call 'tamarin-prover Tutorial.spthy' to inspect the finite variants of the+ Serv_1 rule, which list all possible interactions of the destructors used.+ In our proof search, we will consider all these interactions.++ We also model that the server explicitly checks that the first component of+ the request is equal to '1'. We model this by logging the claimed equality+ and then adapting the security property such that it only considers traces+ where all 'Eq' actions occur with two equal arguments. Note that 'Eq' is NO+ builtin fact. Guarded trace properties are strong enough to formalize this+ requirement without builtin support. Note that inequalities can be modeled+ analogously.++ We log the session-key setup requests received by servers to allow+ formalizing the authentication property for the client.+++Modeling the security properties+--------------------------------++The syntax for specifying security properties uses++ All for universal quantification, temporal variables are prefixed with #+ Ex for existential quantification, temporal variables are prefixed with #+ ==> for implication+ & for conjunction+ | for disjunction+ not for negation+ + f @ i for action constraints, the sort prefix for the temporal variable 'i'+ is optional+ + i < j for temporal ordering, the sort prefix for the temporal variables 'i'+ adn 'j' is optional++ #i = #j for an equality between temporal variables 'i' and 'j'+ x = y for an equality between message variables 'x' and 'y'++Note that apart from public names (delimited using single-quotes), no terms+may occur in guarded trace properties. Moreover, all variables must be+guarded. The error message for an unguarded variable is currently not very+good. ++For universally quantified variables, one has to check that they all occur in+an action constraint right after the quantifier and that the outermost logical operator+inside the quantifier is an implication.+For existentially quantified variables, one has to check that they all occur in+an action constraint right after the quantifier and that the outermost logical+operator inside the quantifier is a conjunction.+Note also that currently the precedence of the logical connectives is not+specified. We therefore recommend to use parentheses, when in doubt.+++The following two properties should be self-explanatory.+*/++lemma Client_session_key_secrecy:+ " /* For all traces, where all equality checks succeed, */+ (All x y #i. Eq(x,y) @ i ==> x = y)+ ==>+ /* it cannot be that a */+ not(+ Ex S k #i #j.+ /* client setup a session key 'k' with a server'S' */+ SessKeyC(S, k) @ #i+ /* and the adversary knows 'k' */+ & K(k) @ #j+ /* without having performed a long-term key reveal on 'S'. */+ & not(Ex #r. LtkReveal(S) @ r) + )+ "+++lemma Client_auth:+ " /* For all traces, where all equality checks succeed, */+ (All x y #i. Eq(x,y) @ i ==> x = y)+ ==>+ /* for all session keys 'k' setup by clients with a server 'S' */+ ( All S k #i. SessKeyC(S, k) @ #i+ ==>+ /* there is a server that answered the request */+ ( (Ex #a. AnswerRequest(S, k) @ a)+ /* or the intruder performed a long-term key reveal on 'S'+ before the key was setup. */+ | (Ex #r. LtkReveal(S) @ r & r < i)+ )+ )+ "++/*+ You can verify them by calling++ tamarin-prover --prove Tutorial.spthy++ This will first output some logging from the constraint solver and then the+ Tutorial security protocol theory with the lemmas and their attached+ (dis)proofs.++ Finding attacks is very useful, to check that a security property is not+ trivial due to too strong preconditions. The following property must not be+ provable, as otherwise there would be no possibility to setup a session key+ with a honest sever.++ We can check for the existence of a trace using the 'exists-trace'+ quantifier in front of the trace formula. When modeling protocols such+ existence proof are very useful sanity checks.+*/+lemma Client_session_key_honest_setup:+ exists-trace+ " (All x y #i. Eq(x,y) @ i ==> x = y)+ & (+ Ex S k #i.+ SessKeyC(S, k) @ #i+ & not(Ex #r. LtkReveal(S) @ r) + )+ "++/*++Interactive proof visualization and construction+------------------------------------------------++Just call ++ tamarin-prover interactive Tutorial.spthy++This will start a web-server that loads all security protocol theories in the+same directory as Tutorial.spthy. Point your browser to++ http://localhost:3001++and explore the the Tutorial theory interactively by clicking on the+'Tutorial' entry in the table of loaded theories. You can prove a lemma+interactively by clicking on the available proof methods (corresponding to+applications of constraint reduction rules) or by calling the 'autoprover' by+right-clicking on a node in the theory overview. Note that that the proof+methods in the GUI are sorted according to our heuristic. Always selecting the+first proof method will result in the same proof as the ones constructed by+the 'autoprover' and '--prove'.+++Conclusion+----------++By now, you should have enough knowledge to understand the case studies from+our CSF'12 paper. Recall that you can find them in the directory listed at the+bottom of the help message, when calling 'tamarin-prover' without any+arguments. Note that Tamarin also outputs the path to the reference MANUAL+specifying and explaining the grammar of security protocol theories and giving+some additional hints on additional theory exploited by Tamarin. If you have+further questions, please do not hesitate to contact either++ Benedikt Schmidt benedikt.schmidt@inf.ethz.ch + Simon Meier simon.meier@inf.ethz.ch+ Cas Cremers cas.cremers@inf.ethz.ch+++BTW, every security protocol theory must be delimited with 'end'.++ (-: HAPPY PROVING :-)+*/++end
data/img/favicon.ico view
binary file changed (1342 → 19718 bytes)
+ data/img/tamarin-logo-128.png view
binary file changed (absent → 60540 bytes)
+ data/img/tamarin-logo-3-0-0.png view
binary file changed (absent → 112997 bytes)
+ data/img/tamarin-logo-3-1-0.png view
binary file changed (absent → 230 bytes)
+ data/img/tamarin-logo-32.png view
binary file changed (absent → 8784 bytes)
+ data/img/tamarin-logo-64.png view
binary file changed (absent → 17042 bytes)
+ data/img/tamarin-logo-96.png view
binary file changed (absent → 30050 bytes)
data/intruder_variants_dh.spthy view
@@ -1,272 +1,258 @@-theory intruder_variants begin+rule (modulo AC) cexp:+ [ !KU( 'exp', x ), !KU( f_.2, x.1 ) ]+ --[ Ded( x^x.1 ) ]->+ [ !KU( 'noexp', x^x.1 ) ] - builtin: diffie-hellman+rule (modulo AC) cinv:+ [ !KU( f_.1, x ) ] --[ Ded( inv(x) ) ]-> [ !KU( 'exp', inv(x) ) ] -section{* Finite Variants of the Intruder Rules *}+rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, x.1 ) ]+ -->+ [ !KD( 'noexp', x.3^(x.1*x.4) ) ] - rule (modulo AC) exp:- [ !KU( 'noexp', x ), !KU( f_.2, x.1 ) ] --> [ !KU( 'exp', x^x.1 ) ]- - rule (modulo AC) inv:- [ !KU( f_.1, x ) ] --> [ !KU( 'noexp', inv(x) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, x.1 ) ]- -->- [ !KD( 'exp', x.3^(x.1*x.4) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^x.3 ), !KU( f_.2, inv(x.3) ) ]- -->- [ !KD( 'exp', x.4 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^inv(x.3) ), !KU( f_.2, x.3 ) ]- -->- [ !KD( 'exp', x.4 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^inv(x.5) ), !KU( f_.2, inv(x.3) ) ]- -->- [ !KD( 'exp', x.4^inv((x.3*x.5)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^inv((x.3*x.5)) ), !KU( f_.2, x.3 ) ]- -->- [ !KD( 'exp', x.4^inv(x.5) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^(x.3*x.5) ), !KU( f_.2, inv(x.3) ) ]- -->- [ !KD( 'exp', x.4^x.5 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^(x.5*inv(x.3)) ), !KU( f_.2, x.3 ) ]- -->- [ !KD( 'exp', x.4^x.5 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, inv((x.4*x.5)) ) ]- -->- [ !KD( 'exp', x.3^inv(x.5) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, (x.5*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.3^x.5 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^inv(x.4) ), !KU( f_.2, (x.3*x.4) ) ]- -->- [ !KD( 'exp', x.5^x.3 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^(x.5*inv(x.6)) ), !KU( f_.2, inv(x.3) ) ]- -->- [ !KD( 'exp', x.4^(x.5*inv((x.3*x.6))) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^inv(x.4) ), !KU( f_.2, (x.5*inv(x.6)) ) ]- -->- [ !KD( 'exp', x.3^(x.5*inv((x.4*x.6))) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.4^(x.5*inv((x.3*x.6))) ), !KU( f_.2, x.3 ) ]- -->- [ !KD( 'exp', x.4^(x.5*inv(x.6)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^inv((x.4*x.6)) ), !KU( f_.2, (x.3*x.4) ) ]- -->- [ !KD( 'exp', x.5^(x.3*inv(x.6)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.4*x.6) ), !KU( f_.2, inv((x.3*x.4)) ) ]- -->- [ !KD( 'exp', x.5^(x.6*inv(x.3)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.4*x.6) ), !KU( f_.2, (x.3*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.5^(x.3*x.6) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.6*inv(x.4)) ), !KU( f_.2, (x.3*x.4) ) ]- -->- [ !KD( 'exp', x.5^(x.3*x.6) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^x.4 ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ]- -->- [ !KD( 'exp', x.3^(x.5*inv(x.6)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.6*inv(x.7)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.5^(x.3*x.6*inv((x.4*x.7))) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.4*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.5 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.4*inv(x.6)) ), !KU( f_.2, inv((x.3*x.4)) ) ]- -->- [ !KD( 'exp', x.5^inv((x.3*x.6)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^inv((x.3*x.6)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.5^inv((x.4*x.6)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.6*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4) ) ]- -->- [ !KD( 'exp', x.5^(x.3*x.6*inv(x.7)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^(x.4*x.5) ), !KU( f_.2, (x.6*inv((x.5*x.7))) ) ]- -->- [ !KD( 'exp', x.3^(x.4*x.6*inv(x.7)) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.4*x.6*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.5^x.6 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.6^(x.5*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ]- -->- [ !KD( 'exp', x.6^x.3 ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.4*x.6*inv(x.7)) ), !KU( f_.2, inv((x.3*x.4)) ) ]- -->- [ !KD( 'exp', x.5^(x.6*inv((x.3*x.7))) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.6^inv((x.4*x.7)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ]- -->- [ !KD( 'exp', x.6^(x.3*inv((x.5*x.7))) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.4*inv((x.3*x.6))) ), !KU( f_.2, (x.3*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.5^inv(x.6) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ]- -->- [ !KD( 'exp', x.3^inv(x.6) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.6*inv((x.4*x.7))) ) ]- -->- [ !KD( 'exp', x.3^(x.6*inv((x.5*x.7))) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.6^(x.5*x.7*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) )- ]- -->- [ !KD( 'exp', x.6^(x.3*x.7) ) ]- - rule (modulo AC) exp:- [ !KD( 'noexp', x.5^(x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) ) ]- -->- [ !KD( 'exp', x.5^(x.6*inv((x.4*x.7))) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*x.6*inv((x.4*x.7))) )- ]- -->- [ !KD( 'exp', x.3^(x.6*inv(x.7)) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.5^(x.4*x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) )- ]- -->- [ !KD( 'exp', x.5^(x.6*inv(x.7)) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.6^(x.5*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) )- ]- -->- [ !KD( 'exp', x.6^(x.3*inv(x.7)) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.6^(x.5*x.7*inv(x.3)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) )- ]- -->- [ !KD( 'exp', x.6^(x.7*inv(x.4)) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.6^(x.5*x.7*inv(x.8)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) )- ]- -->- [ !KD( 'exp', x.6^(x.3*x.7*inv((x.4*x.8))) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.6^(x.7*inv((x.4*x.8))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) )- ]- -->- [ !KD( 'exp', x.6^(x.3*x.7*inv((x.5*x.8))) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.6^(x.5*inv((x.3*x.7))) ),- !KU( f_.2, (x.3*inv((x.4*x.5))) )- ]- -->- [ !KD( 'exp', x.6^inv((x.4*x.7)) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.3^(x.4*x.5*inv(x.6)) ),- !KU( f_.2, (x.6*x.7*inv((x.5*x.8))) )- ]- -->- [ !KD( 'exp', x.3^(x.4*x.7*inv(x.8)) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.6^(x.5*x.7*inv((x.4*x.8))) ),- !KU( f_.2, (x.3*x.4*inv(x.5)) )- ]- -->- [ !KD( 'exp', x.6^(x.3*x.7*inv(x.8)) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.7^(x.6*inv((x.4*x.8))) ),- !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) )- ]- -->- [ !KD( 'exp', x.7^(x.3*inv((x.5*x.8))) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.6^(x.5*x.7*inv((x.3*x.8))) ),- !KU( f_.2, (x.3*inv((x.4*x.5))) )- ]- -->- [ !KD( 'exp', x.6^(x.7*inv((x.4*x.8))) ) ]- - rule (modulo AC) exp:- [- !KD( 'noexp', x.7^(x.6*x.8*inv((x.4*x.9))) ),- !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) )- ]- -->- [ !KD( 'exp', x.7^(x.3*x.8*inv((x.5*x.9))) ) ]- - rule (modulo AC) inv:- [ !KD( f_.1, inv(x.2) ) ] --> [ !KD( 'noexp', x.2 ) ]+rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^x.3 ), !KU( f_.2, inv(x.3) ) ]+ -->+ [ !KD( 'noexp', x.4 ) ] -end+rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^inv(x.3) ), !KU( f_.2, x.3 ) ]+ -->+ [ !KD( 'noexp', x.4 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^inv(x.5) ), !KU( f_.2, inv(x.3) ) ]+ -->+ [ !KD( 'noexp', x.4^inv((x.3*x.5)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^inv((x.3*x.5)) ), !KU( f_.2, x.3 ) ]+ -->+ [ !KD( 'noexp', x.4^inv(x.5) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^(x.3*x.5) ), !KU( f_.2, inv(x.3) ) ]+ -->+ [ !KD( 'noexp', x.4^x.5 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^(x.5*inv(x.3)) ), !KU( f_.2, x.3 ) ]+ -->+ [ !KD( 'noexp', x.4^x.5 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, inv((x.4*x.5)) ) ]+ -->+ [ !KD( 'noexp', x.3^inv(x.5) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, (x.5*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.3^x.5 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^inv(x.4) ), !KU( f_.2, (x.3*x.4) ) ]+ -->+ [ !KD( 'noexp', x.5^x.3 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^(x.5*inv(x.6)) ), !KU( f_.2, inv(x.3) ) ]+ -->+ [ !KD( 'noexp', x.4^(x.5*inv((x.3*x.6))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^inv(x.4) ), !KU( f_.2, (x.5*inv(x.6)) ) ]+ -->+ [ !KD( 'noexp', x.3^(x.5*inv((x.4*x.6))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.4^(x.5*inv((x.3*x.6))) ), !KU( f_.2, x.3 ) ]+ -->+ [ !KD( 'noexp', x.4^(x.5*inv(x.6)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^inv((x.4*x.6)) ), !KU( f_.2, (x.3*x.4) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.3*inv(x.6)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*x.6) ), !KU( f_.2, inv((x.3*x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.6*inv(x.3)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*x.6) ), !KU( f_.2, (x.3*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.3*x.6) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.6*inv(x.4)) ), !KU( f_.2, (x.3*x.4) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.3*x.6) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ]+ -->+ [ !KD( 'noexp', x.3^(x.5*inv(x.6)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.6*inv(x.7)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.3*x.6*inv((x.4*x.7))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*inv(x.6)) ), !KU( f_.2, inv((x.3*x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^inv((x.3*x.6)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^inv((x.3*x.6)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^inv((x.4*x.6)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.6*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.3*x.6*inv(x.7)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^(x.4*x.5) ), !KU( f_.2, (x.6*inv((x.5*x.7))) ) ]+ -->+ [ !KD( 'noexp', x.3^(x.4*x.6*inv(x.7)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*x.6*inv(x.3)) ), !KU( f_.2, (x.3*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^x.6 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.6^(x.5*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ]+ -->+ [ !KD( 'noexp', x.6^x.3 ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*x.6*inv(x.7)) ), !KU( f_.2, inv((x.3*x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.6*inv((x.3*x.7))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.6^inv((x.4*x.7)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ]+ -->+ [ !KD( 'noexp', x.6^(x.3*inv((x.5*x.7))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*inv((x.3*x.6))) ), !KU( f_.2, (x.3*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^inv(x.6) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*inv((x.4*x.6))) ) ]+ -->+ [ !KD( 'noexp', x.3^inv(x.6) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.6*inv((x.4*x.7))) ) ]+ -->+ [ !KD( 'noexp', x.3^(x.6*inv((x.5*x.7))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.6^(x.5*x.7*inv(x.4)) ), !KU( f_.2, (x.3*x.4*inv(x.5)) ) ]+ -->+ [ !KD( 'noexp', x.6^(x.3*x.7) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) ) ]+ -->+ [ !KD( 'noexp', x.5^(x.6*inv((x.4*x.7))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.3^(x.4*inv(x.5)) ), !KU( f_.2, (x.5*x.6*inv((x.4*x.7))) )+ ]+ -->+ [ !KD( 'noexp', x.3^(x.6*inv(x.7)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.5^(x.4*x.6*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv(x.4)) )+ ]+ -->+ [ !KD( 'noexp', x.5^(x.6*inv(x.7)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.6^(x.5*inv((x.4*x.7))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) )+ ]+ -->+ [ !KD( 'noexp', x.6^(x.3*inv(x.7)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.6^(x.5*x.7*inv(x.3)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) )+ ]+ -->+ [ !KD( 'noexp', x.6^(x.7*inv(x.4)) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.6^(x.5*x.7*inv(x.8)) ), !KU( f_.2, (x.3*inv((x.4*x.5))) )+ ]+ -->+ [ !KD( 'noexp', x.6^(x.3*x.7*inv((x.4*x.8))) ) ]++rule (modulo AC) dexp:+ [ !KD( 'exp', x.6^(x.7*inv((x.4*x.8))) ), !KU( f_.2, (x.3*x.4*inv(x.5)) )+ ]+ -->+ [ !KD( 'noexp', x.6^(x.3*x.7*inv((x.5*x.8))) ) ]++rule (modulo AC) dexp:+ [+ !KD( 'exp', x.6^(x.5*inv((x.3*x.7))) ), !KU( f_.2, (x.3*inv((x.4*x.5))) )+ ]+ -->+ [ !KD( 'noexp', x.6^inv((x.4*x.7)) ) ]++rule (modulo AC) dexp:+ [+ !KD( 'exp', x.3^(x.4*x.5*inv(x.6)) ),+ !KU( f_.2, (x.6*x.7*inv((x.5*x.8))) )+ ]+ -->+ [ !KD( 'noexp', x.3^(x.4*x.7*inv(x.8)) ) ]++rule (modulo AC) dexp:+ [+ !KD( 'exp', x.6^(x.5*x.7*inv((x.4*x.8))) ),+ !KU( f_.2, (x.3*x.4*inv(x.5)) )+ ]+ -->+ [ !KD( 'noexp', x.6^(x.3*x.7*inv(x.8)) ) ]++rule (modulo AC) dexp:+ [+ !KD( 'exp', x.7^(x.6*inv((x.4*x.8))) ),+ !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) )+ ]+ -->+ [ !KD( 'noexp', x.7^(x.3*inv((x.5*x.8))) ) ]++rule (modulo AC) dexp:+ [+ !KD( 'exp', x.6^(x.5*x.7*inv((x.3*x.8))) ),+ !KU( f_.2, (x.3*inv((x.4*x.5))) )+ ]+ -->+ [ !KD( 'noexp', x.6^(x.7*inv((x.4*x.8))) ) ]++rule (modulo AC) dexp:+ [+ !KD( 'exp', x.7^(x.6*x.8*inv((x.4*x.9))) ),+ !KU( f_.2, (x.3*x.4*inv((x.5*x.6))) )+ ]+ -->+ [ !KD( 'noexp', x.7^(x.3*x.8*inv((x.5*x.9))) ) ]++rule (modulo AC) dinv:+ [ !KD( f_.1, inv(x.2) ) ] --> [ !KD( 'exp', x.2 ) ]
data/js/tamarin-prover-ui.js view
@@ -1,5 +1,5 @@ /**- * Dh-proto-proof ui controller+ * Tamarin ui controller * @author Cedric Staub */ @@ -9,13 +9,22 @@ var theory = { /**- * Convert a relative path into an absolute one.- * @param section Section/display, for example main or debug.+ * Convert a relative path into an absolute one for the currently shown theory.+ * @param action The action, for example "overview" or "main". * @param path The relative path. * @return The absolute path. */ absolutePath: function(section, path) { return "/thy/" + this.idx + "/" + section + "/" + path;+ },++ /**+ * Extract the theory path from the given url path.+ * @param urlPath The url path+ * @return The theory path.+ */+ extractTheoryPath : function(urlPath) {+ return urlPath.split("/").splice(4).join("/"); } } @@ -138,10 +147,11 @@ // Add keyboard shortcuts var shortcuts = {- 74 : function() { proofScript.jump('next/smart', null); },- 75 : function() { proofScript.jump('prev/smart', null); },- 106 : function() { proofScript.jump('next/normal', null); },- 107 : function() { proofScript.jump('prev/normal', null); }+ 97 : function() { mainDisplay.applyAutoprover(); }, // a+ 74 : function() { proofScript.jump('next/smart', null); }, // j+ 75 : function() { proofScript.jump('prev/smart', null); }, // k+ 106 : function() { proofScript.jump('next/normal', null); }, // J+ 107 : function() { proofScript.jump('prev/normal', null); } // K } for(i = 1; i < 10; i++) {@@ -152,6 +162,13 @@ this.add_shortcuts(shortcuts); + // set active link+ path = window.location.pathname.split("/");+ path[3] = "main";+ this.setActiveLink(path.join("/"));+ proofScript.focusActive();++ // Initialize dialog box $("div#dialog").dialog({ autoOpen: false,@@ -168,14 +185,11 @@ $("#proof a.proof-step").contextMenu( { menu: "contextMenu" }, function(action, el, pos) {+ var theoryPath = theory.extractTheoryPath($(el).attr("href")); mainDisplay.loadTarget(- action,- $(el).attr("href"),- function() {- var path = $(el).attr("href");- $.cookie("last-target", path, { path: "/" });- $.cookie("jump-to-target", true, { path: "/" });- });+ theory.absolutePath(action,theoryPath),+ null+ ); }); // Click handler for save link@@ -233,15 +247,7 @@ "div#proof a.internal-link", "main", null);- - // Install handlers on edit links (lemma)- events.installRelativeClickHandler(- "div#proof a.internal-link.edit-link",- "edit/path",- function(el) {- events.installFormHandler();- });- + // Install handlers on delete links events.installRelativeClickHandler( "div#proof a.internal-link.delete-link",@@ -252,21 +258,21 @@ events.installRelativeClickHandler( "div#proof a.internal-link.proof-step", "main",- function(el) {- var path = $(el).attr("href");- $.cookie("last-target", path, { path: "/" });- $.cookie("jump-next-open-goal", true, { path: "/" });- });- + null+ );++ // Install click handlers on main+ events.installRelativeClickHandler(+ "div#ui-main-display a.internal-link",+ "main",+ null);+ // Install handlers on removal links events.installRelativeClickHandler( "div#proof a.internal-link.remove-step", "del/path",- function(el) {- var path = $(el).attr("href");- $.cookie("last-target", path, { path: "/" });- $.cookie("jump-to-target", true, { path: "/" });- });+ null+ ); }, /**@@ -341,7 +347,18 @@ var dialog = $("div#dialog"); dialog.html(msg.replace("\n","<br>")); dialog.dialog('open');+ },++ /**+ * Set active link+ * @param target The path+ */+ setActiveLink: function(target) {+ var selector = "a.internal-link[href='" + target + "']";+ $("a.active-link").removeClass("active-link");+ $(selector).first().addClass("active-link"); }+ } @@ -400,7 +417,7 @@ ev.preventDefault(); var element = $(this); mainDisplay.loadTarget(- section,+ // section, element.attr("href"), function() { if(callback) callback(element);@@ -419,10 +436,11 @@ cancel.click(function(ev) { ev.preventDefault();+ // FIXME: where to jump here if($.cookie("last-target")) {- mainDisplay.loadTarget("main", $.cookie("last-target"));+ mainDisplay.loadTarget($.cookie("last-target")); } else {- mainDisplay.loadTarget("main", "rules");+ mainDisplay.loadTarget("rules"); } }); @@ -486,9 +504,9 @@ if(active.length > 0) { var current = active.attr("href"); - + server.performASR(- theory.absolutePath(mode, current),+ theory.absolutePath(mode, theory.extractTheoryPath(current)), "text", false, // Success callback@@ -498,7 +516,7 @@ if(link.length > 0) { mainDisplay.loadTarget(- "main",+ // "main", link.attr("href"), function() { proofScript.focusActive();@@ -566,23 +584,34 @@ */ applyProofMethod: function(num) { var path = $("a.active-link").attr("href");- $.cookie("last-target", path, { path: "/" });- $.cookie("jump-next-open-goal", true, { path: "/" }); var element = $("#ui-main-display"); var methods = element.find("div.methods a.internal-link"); - if(methods.length >= num) {- $(methods.get([ num - 1 ])).click();- }+ if(methods.length >= num) $(methods.get([ num - 1 ])).click(); }, + applyAutoprover: function() {+ var auto = $("#ui-main-display").find("a.internal-link.autoprove");++ if(auto.length >= 1) $(auto.get(0)).click();+ },++ /** * Update main view with new HTML data. * @param html_data The html data. */ setContent: function(title, html_data) {- if(title) $("#main-title").html(title);+ if(title) {+ // Only use first line for title+ var titleLines = title.split('<br/>');+ var titleText = titleLines[0];+ if(titleLines.length > 1 && titleLines[1] != "") {+ titleText = titleText + " ..."+ }+ $("#main-title").html(titleText);+ } var element = $("#ui-main-display"); var wrapper = $("#main-wrapper");@@ -628,10 +657,10 @@ * @param target The target to load. * @param callback Optional callback to call after successful load. */- loadTarget: function(section, target, callback) {+ loadTarget: function(target, callback) { // Load main view server.performASR(- theory.absolutePath(section, target),+ target, "json", false, // Success callback@@ -640,23 +669,12 @@ server.handleJson(data, function(title, html_data) { mainDisplay.setContent(title, html_data); - // Set active-link class for target- var selector = "a.internal-link[href='" + target + "']";- $("a.active-link").removeClass("active-link");- $(selector).first().addClass("active-link");- - /*- // Load debug view- server.performASR(- theory.absolutePath('debug', target),- "html",- false,- // Success callback- function(data, textStatus) {- $("#ui-debug-display").html(data);- }- );- */+ if (window.history && window.history.pushState) {+ var url = theory.absolutePath("overview", theory.extractTheoryPath(target));+ window.history.replaceState({}, "", url);+ }++ ui.setActiveLink(target); }); // Call optional callback@@ -692,14 +710,6 @@ * Initialize when document is ready. */ $(document).ready(function() {- // Automatically submit upload form on root- $("input[type=file]").change(function() {- var obj = $(this);- if(obj.val()) {- obj.parents("form").submit(); - }- });- // Only run rest of script if the main display is available var main_display = $("#ui-main-display"); if(main_display.length != 1) return;@@ -730,18 +740,4 @@ // Initialize user interface ui.init();-- // Process jump instructions- if($.cookie("jump-to-target")) {- if($.cookie("last-target")) {- proofScript.jumpToTarget($.cookie("last-target"));- }- $.cookie("jump-to-target", null, { path: "/" });- } else if($.cookie("jump-next-open-goal")) {- if($.cookie("last-target")) {- proofScript.jumpNextOpenGoal($.cookie("last-target"));- }- $.cookie("jump-next-open-goal", null, { path: "/" });- }- });
interactive-only-src/Paths_tamarin_prover.hs view
@@ -12,7 +12,7 @@ version :: Version-version = Version {versionBranch = [0,1,0], versionTags = []}+version = Version {versionBranch = [0,4,0,0], versionTags = []} bindir, libdir, datadir, libexecdir :: FilePath bindir = "./"
src/Main.hs view
@@ -1,721 +1,18 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} -- |--- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE) -- -- Maintainer : Simon Meier <iridcode@gmail.com>--- Portability : GHC only ----- Main module for the tamarin prover.+-- Main module for the Tamarin prover without a GUI module Main where -import Prelude hiding (id, (.))--import Data.List-import Data.Maybe-import Data.Version (showVersion)-import Data.Monoid-import Data.Char (isSpace, toLower)-import Data.Label--import Control.Basics-import Control.Category-import Control.Exception as E--import System.Console.CmdArgs.Explicit-import System.Console.CmdArgs.Text--import System.Exit-import System.FilePath-import System.Directory-import System.Environment-import System.IO-import System.Process-import System.Timing (timed)--import Extension.Prelude--import qualified Text.Isar as Isar--import Theory-import Theory.Parser-import Theory.Wellformedness--import Paths_tamarin_prover--import Web.Dispatch-import qualified Web.Settings-import qualified Network.Wai.Handler.Warp as Warp (run)----------------------------------------------------------------------------------- General definitions for tamarin----------------------------------------------------------------------------------- | Program name-programName :: String-programName = "tamarin-prover"---- | Version string-versionStr :: FilePath -- ^ Path to LICENCE file.- -> String-versionStr licensePath = unlines- [ concat- [ programName- , " "- , showVersion version- , ", (C) Benedikt Schmidt, Simon Meier, ETH Zurich 2010-2012"- ]- , ""- , "This program comes with ABSOLUTELY NO WARRANTY. It is free software, and you"- , "are welcome to redistribute it according to its LICENSE, see"- , "'" ++ licensePath ++ "'."- ]---- | Line width to use.-lineWidth :: Int-lineWidth = 110--shortLineWidth :: Int-shortLineWidth = 78--{---- | Version string with HTML markup.-htmlVersionStr :: String-htmlVersionStr = concat- [ link "http://www.infsec.ethz.ch/research/software#TAMARIN" programName- , " "- , showVersion version- , ", © "- , link "https://infsec.ethz.ch/infsec/people/benschmi/index" "Benedikt Schmidt"- , ", "- , link "http://people.inf.ethz.ch/meiersi" "Simon Meier"- , ", ETH Zurich 2010-2012"- ]- where- link href name = - "<a href=\"" ++ href ++ "\" target=\"new\">" ++ name ++ "</a>"--}----------------------------------------------------------------------------------- Argument parsing helpers---------------------------------------------------------------------------------type Arguments = [(String,String)]--argExists :: String -> Arguments -> Bool-argExists a = isJust . findArg a--findArg :: MonadPlus m => String -> Arguments -> m String-findArg a' as = msum [ return v | (a,v) <- as, a == a' ]--getArg :: String -> Arguments -> String-getArg a = - fromMaybe (error $ "getArg: argument '" ++ a ++ "' not found") . findArg a--addArg :: String -> String -> Arguments -> Arguments-addArg a v = ((a,v):)--withArguments :: Mode Arguments -> (Arguments -> IO ()) -> IO ()-withArguments argMode io = do- licensePath <- getDataFileName "LICENSE"- processArgs argMode >>= run licensePath- where- run licensePath as- | argExists "help" as = print $ helpText HelpFormatAll argMode- | argExists "version" as = putStrLn $ versionStr licensePath- | otherwise = io as--updateArg :: String -> String -> Arguments -> Either a Arguments-updateArg a v = Right . addArg a v--addEmptyArg :: String -> Arguments -> Arguments-addEmptyArg a = addArg a ""- --- | Main mode.-mainMode :: Mode [(String,String)]-mainMode = - -- translateMode { modeGroupModes = toGroup [interactiveMode] }- translateMode { modeGroupModes = toGroup [interactiveMode, intruderMode] }- where -- defaultMode name help = Mode- { modeGroupModes = toGroup []- , modeNames = [name] - , modeValue = [] - , modeCheck = updateArg "mode" name- , modeReform = const Nothing-- no reform possibility- , modeHelp = help- , modeHelpSuffix = []- , modeArgs = Nothing -- no positional arguments- , modeGroupFlags = toGroup [] -- no flags- }-- translateMode =- ( defaultMode programName - "Batch mode for analyzing security protocols using DH-exponentiation."- )- { modeCheck = updateArg "mode" "translate"- , modeArgs = Just $ flagArg (updateArg "inFile") "FILES"- , modeGroupFlags = Group - { groupUnnamed =- theoryLoadFlags ++- -- [ flagNone ["html"] (addEmptyArg "html")- -- "generate HTML visualization of proofs"-- -- [ flagNone ["no-compress"] (addEmptyArg "noCompress")- -- "Do not use compressed sequent visualization"-- [ flagNone ["parse-only"] (addEmptyArg "parseOnly")- "Parse the input file and pretty-print it as-is"- ] ++- outputFlags ++- toolFlags - , groupHidden = []- , groupNamed =- [ ("About"- , [ flagHelpSimple (addEmptyArg "help")- , flagVersion (addEmptyArg "version")- ] )- ]- }- }--- intruderMode =- ( defaultMode "intruder" - "Compute the variants of the intruder rules for DH-exponentiation."- )- { modeArgs = Nothing - , modeCheck = updateArg "mode" "intruder"- , modeGroupFlags = toGroup outputFlags- }-- outputFlags = - [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file"- , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR" "Output directory"- ]-- toolFlags = - -- [ flagOpt "dot" ["with-dot"] (updateArg "withDot") "FILE" "Path to GraphViz 'dot' tool"- [ flagOpt "maude" ["with-maude"] (updateArg "withMaude") "FILE" "Path to 'maude' rewriting tool"- ]-- interactiveFlags =- [ flagOpt "" ["port","p"] (updateArg "port") "PORT" "Port to listen on"- -- , flagOpt "" ["datadir"] (updateArg "datadir") "DATADIR" "Directory with data"- , flagNone ["debug"] (addEmptyArg "debug") "Show server debugging output"- -- , flagNone ["autosave"] (addEmptyArg "autosave") "Automatically save proof state"- -- , flagNone ["loadstate"] (addEmptyArg "loadstate") "Load proof state if present"- ] ++- theoryLoadFlags ++- toolFlags-- interactiveMode =- ( defaultMode "interactive"- "Start a web-server for interactively constructing the security proofs."- )- { modeArgs = Just $ flagArg (updateArg "workDir") "WORKDIR"- , modeCheck = updateArg "mode" "interactive"- , modeGroupFlags = toGroup interactiveFlags- }----- | Disply help message and exit.-errHelpExit :: String -> IO ()-errHelpExit msg = do- putStrLn $ "error: " ++ msg- putStrLn $ ""- putStrLn $ showText (Wrap lineWidth) - $ helpText HelpFormatDefault mainMode- examplePath <- getDataFileName "examples"- let userGuidePath = examplePath </> "UserGuide.spthy"- csf12Path = examplePath </> "csf12" </> "*.spthy"- csf12Cmd = programName ++ " --prove -Ocase-studies +RTS -N -RTS " ++ csf12Path - csf12Cmd' = programName ++ " interactive +RTS -N -RTS " ++ csf12Path - separator = putStrLn $ replicate shortLineWidth '-'- putPath info path = putStrLn info >> putStrLn (" " ++ path ++ "\n")- separator- putPath "For example protocol models see" examplePath- putPath "Their syntax is explained in" userGuidePath- putPath "To run all case-studies from our CSF'12 submission, use" csf12Cmd- putPath "To construct their security proofs interactively, use" csf12Cmd'- putStrLn - "Note that the +RTS -N -RTS flags instruct the Haskell runtime system to\n\- \use as many cores as your system has. This speeds-up some of the computations."- separator- exitFailure- where----------------------------------------------------------------------------------- Main mode execution-------------------------------------------------------------------------------+#ifdef NO_GUI+import qualified Main_NoGui as M+#else+import qualified Main_Full as M+#endif --- | Main function. main :: IO ()-main = - withArguments mainMode selectMode- where- selectMode as = case findArg "mode" as of- Just "translate" -> translate as- Just "intruder" -> intruderVariants as- Just "interactive" -> interactive as- Just m -> error $ "main: unknown mode '" ++ m ++ "'"- Nothing -> error $ "main: no mode given"- --- shared support functions------------------------------renderDoc :: Isar.Doc -> String-renderDoc = Isar.renderStyle (Isar.style { Isar.lineLength = lineWidth }) ------------------------------------------------------------------------------------ Intruder variants mode execution---------------------------------------------------------------------------------intruderVariants :: Arguments -> IO ()-intruderVariants as = do- ensureMaude as- hnd <- startMaude (maudePath as) dhMaudeSig- let thy = dhIntruderTheory hnd- thyString = renderDoc $ prettyOpenTheory thy- putStrLn thyString- writeThy thyString- where- -- output generation- ---------------------- writeThy thyString = case optOutPath of- Just outPath -> writeFileWithDirs outPath thyString- Nothing -> return ()- - -- Output file name, if output is desired.- optOutPath :: Maybe FilePath- optOutPath = - do outFile <- findArg "outFile" as- guard (outFile /= "")- return outFile- <|>- do outDir <- findArg "outDir" as- return $ outDir </> defaultIntrVariantsPath --defaultIntrVariantsPath :: FilePath-defaultIntrVariantsPath = "intruder_variants_dh.spthy"------------------------------------------------------------------------------------ Theory loading: shared between interactive and batch mode-------------------------------------------------------------------------------- -theoryLoadFlags :: [Flag Arguments]-theoryLoadFlags = - [ flagNone ["prove"] (addEmptyArg "addProofs")- "Attempt to prove all security properties"-- , flagOpt "dfs" ["stop-on-attack"] (updateArg "stopOnAttack") "DFS|BFS|NONE"- "How to search for attacks (default DFS)"-- -- , flagOpt "5" ["bound", "b"] (updateArg "bound") "INT"- -- "Bound the depth of the proofs"-- --, flagOpt "" ["intruder","i"] (updateArg "intruderVariants") "FILE"- -- "Cached intruder rules to use"-- , flagOpt "" ["defines","D"] (updateArg "defines") "STRING"- "Define flags for pseudo-preprocessor."- ]--loadOpenThy :: Arguments -> FilePath -> IO OpenTheory-loadOpenThy = fst . loadThy--loadClosedThy :: Arguments -> FilePath -> IO ClosedTheory-loadClosedThy = uncurry (>=>) . loadThy--loadClosedWfThy :: Arguments -> FilePath -> IO ClosedTheory-loadClosedWfThy as file = do- thy <- loadOpen file- case checkWellformedness thy of- [] -> close thy- report -> error $ renderDoc $ prettyWfErrorReport report- where- (loadOpen, close) = loadThy as--loadClosedThyString :: Arguments -> String -> IO ClosedTheory-loadClosedThyString = uncurry (>=>) . loadThyString---- | Load an open/closed theory from a file.-loadThy :: Arguments -> (FilePath -> IO OpenTheory, OpenTheory -> IO ClosedTheory)-loadThy as = loadGenericThy (parseOpenTheory (defines as)) as ---- | Load an open/closed theory from a string.-loadThyString :: Arguments -> (String -> IO OpenTheory, OpenTheory -> IO ClosedTheory)-loadThyString as = loadGenericThy loader as- where- loader str =- case parseOpenTheoryString (defines as) str of- Right thy -> return thy- Left err -> error $ show err ---- | The defined pre-processor flags in the argument.-defines :: Arguments -> [String]-defines = findArg "defines"---- | Load an open/closed theory given a loader function.-loadGenericThy :: (a -> IO OpenTheory)- -> Arguments - -> (a -> IO OpenTheory, OpenTheory -> IO ClosedTheory)-loadGenericThy loader as =- (loader, (closeThy as) <=< tryAddIntrVariants)- where- -- intruder variants- --------------------- tryAddIntrVariants :: OpenTheory -> IO OpenTheory- tryAddIntrVariants thy0 = do- let msig = get (sigpMaudeSig . thySignature) thy0- thy = addIntrRuleACs (subtermIntruderRules msig ++ specialIntruderRules) thy0- if (enableDH msig) then- do variantsFile <- getDataFileName "intruder_variants_dh.spthy"- ifM (doesFileExist variantsFile)- (do intrVariants <- - get thyCache <$> parseOpenTheory (defines as) variantsFile- return $ addIntrRuleACs intrVariants thy- )- (error $ "could not find intruder message deduction theory '" - ++ variantsFile ++ "'")- else return thy---- | Close a theory according to arguments.-closeThy :: Arguments -> OpenTheory -> IO ClosedTheory-closeThy as = - fmap (proveTheory prover) . closeTheory (maudePath as) . wfCheck - where- -- handles to relevant arguments- --------------------------------- proofBound = read <$> findArg "bound" as- requireProofs = argExists "addProofs" as-- stopOnAttack :: Maybe String- stopOnAttack = findArg "stopOnAttack" as-- -- wellformedness check- ------------------------ wfCheck :: OpenTheory -> OpenTheory- wfCheck thy = - noteWellformedness- (checkWellformedness thy) thy-- -- protocol transformation- --------------------------- prover :: Prover- prover - | requireProofs = cutAttack $ maybe id boundProver proofBound autoProver- | otherwise = mempty- where - cutAttack = mapProverProof $ case map toLower <$> stopOnAttack of- Nothing -> cutOnAttackDFS- Just "dfs" -> cutOnAttackDFS- Just "none" -> id- Just "bfs" -> cutOnAttackBFS- Just other -> error $ "unknown stop-on-attack method: " ++ other- ---------------------------------------------------------------------------------- Tool paths (shared between interactive and batch mode)----------------------------------------------------------------------------------- | Path to maude tool-maudePath :: Arguments -> FilePath-maudePath = fromMaybe "maude" . findArg "withMaude"---- | Path to dot tool-dotPath :: Arguments -> FilePath-dotPath = fromMaybe "dot" . findArg "withDot"----------------------------------------------------------------------------------- Interactive proof mode execution----------------------------------------------------------------------------------- | Prove lemmas interactively.-interactive :: Arguments -> IO ()-interactive as = case findArg "workDir" as of- Nothing -> errHelpExit "no working directory specified"- Just workDir0 -> do- -- determine working directory- wdIsFile <- doesFileExist workDir0- let workDir | wdIsFile = takeDirectory workDir0- | otherwise = workDir0- wdIsDir <- doesDirectoryExist workDir- if wdIsDir- then do- -- process theories- ensureGraphVizDot as- ensureMaude as- putStrLn ""- port <- readPort- dataDir <- readDataDir- putStrLn $ intercalate "\n"- [ "The server is starting up on localhost with port " ++ show port ++ "."- , "Browse to http://localhost:" ++ show port ++ " once the server is ready."- , ""- , "Loading the security protocol theories '" ++ workDir </> "*.spthy" ++ "' ..."- ]- withWebUI workDir (argExists "loadstate" as) (argExists "autosave" as)- (loadClosedWfThy as) (loadClosedThyString as) (closeThy as)- (argExists "debug" as) (Just dataDir) (Warp.run port)- - else errHelpExit $ "directory '" ++ workDir ++ "' does not exist."- where- -- Datadir argument- readDataDir =- case findArg "datadir" as of- [d] -> return d- _ -> getDataDir-- -- Port argument- ----------------- readPort = do- let port = findArg "port" as >>= fmap fst . listToMaybe . reads- when- (argExists "port" as && isNothing port) - (putStrLn $ "Unable to read port from argument `"- ++fromMaybe "" (findArg "port" as)++"'. Using default.")- return $ fromMaybe Web.Settings.defaultPort port----------------------------------------------------------------------------------- Translate mode execution----------------------------------------------------------------------------------- | Execute a translation.-translate :: Arguments -> IO ()-translate as - | null inFiles = errHelpExit "no input files given"- | otherwise = do- ensureMaude as- putStrLn $ ""- summaries <- mapM processThy inFiles- putStrLn $ ""- putStrLn $ replicate shortLineWidth '='- putStrLn $ "summary of processed files:"- putStrLn $ ""- putStrLn $ renderDoc $ Isar.vcat $ intersperse (Isar.text "") summaries- putStrLn $ ""- putStrLn $ replicate shortLineWidth '='- where- -- handles to arguments- ------------------------ inFiles = reverse $ findArg "inFile" as-- -- output generation- ---------------------- dryRun = not (argExists "outFile" as || argExists "outDir" as)-- mkOutPath :: FilePath -- ^ Input file name.- -> FilePath -- ^ Output file name.- mkOutPath inFile = - fromMaybe (error "please specify an output file or directory") $- do outFile <- findArg "outFile" as- guard (outFile /= "")- return outFile- <|>- do outDir <- findArg "outDir" as- return $ mkAutoPath outDir (takeBaseName inFile)-- -- automatically generate the filename for output- mkAutoPath :: FilePath -> String -> FilePath- mkAutoPath dir baseName- | argExists "html" as = dir </> baseName- | otherwise = dir </> addExtension (baseName ++ "_analyzed") "spthy"-- -- theory processing functions- -------------------------------- processThy :: FilePath -> IO (Isar.Doc)- processThy inFile- -- | argExists "html" as = - -- generateHtml inFile =<< loadClosedThy as inFile- | argExists "parseOnly" as =- out (const Isar.emptyDoc) prettyOpenTheory (loadOpenThy as inFile)- | otherwise = - out prettyClosedSummary prettyClosedTheory (loadClosedThy as inFile)- where- out :: (a -> Isar.Doc) -> (a -> Isar.Doc) -> IO a -> IO Isar.Doc- out summaryDoc fullDoc load = do- res <- try $- if dryRun - then do writeWithSummary putStrLn "<no file written>"- else do- putStrLn $ ""- putStrLn $ "analyzing: " ++ inFile- putStrLn $ ""- let outFile = mkOutPath inFile- summary <- writeWithSummary (writeFileWithDirs outFile) outFile- putStrLn $ replicate shortLineWidth '-'- putStrLn $ renderDoc summary- putStrLn $ ""- putStrLn $ replicate shortLineWidth '-'- return summary- case res of- Right x -> return x- Left x -> return $ Isar.vcat $ map Isar.text- [ "failed to analyze: " ++ inFile- , ""- , " exception: " ++ show (x :: IOException)- ]- where- writeWithSummary :: (String -> IO ()) -> FilePath -> IO Isar.Doc- writeWithSummary io outName = do- (thySummary, t) <- timed $ do- thy <- load- io $ renderDoc $ fullDoc thy- return $ summaryDoc thy- return $ Isar.vcat- [ Isar.text $ "analyzed: " ++ inFile- , Isar.text $ ""- , Isar.text $ " output: " ++ outName- , Isar.text $ " processing time: " ++ show t- , Isar.text $ ""- , Isar.nest 2 thySummary- ]-- {- TO BE REACTIVATED once infrastructure from interactive mode can be used-- -- static html generation- --------------------------- generateHtml :: FilePath -- ^ Input file- -> ClosedTheory -- ^ Theory to pretty print- -> IO ()- generateHtml inFile thy = do- cmdLine <- getCommandLine- time <- getCurrentTime- cpu <- getCpuModel- template <- getHtmlTemplate- theoryToHtml $ GenerationInput {- giHeader = "Generated by " ++ htmlVersionStr- , giTime = time- , giSystem = cpu- , giInputFile = inFile- , giTemplate = template- , giOutDir = mkOutPath inFile- , giTheory = thy- , giCmdLine = cmdLine- , giCompress = not $ argExists "noCompress" as- }-- -}----------------------------------------------------------------------------------- Utility functions----------------------------------------------------------------------------------- | Write a file and ensure that its containing directory exists.-writeFileWithDirs :: FilePath -> String -> IO ()-writeFileWithDirs file output = do- createDirectoryIfMissing True (takeDirectory file)- writeFile file output---- | Get the string constituting the command line.-getCommandLine :: IO String-getCommandLine = do- arguments <- getArgs- return . concat . intersperse " " $ programName : arguments---- | Read the cpu info using a call to cat /proc/cpuinfo-getCpuModel :: IO String-getCpuModel = - handle handler $ do- (_, info, _) <- readProcessWithExitCode "cat" ["/proc/cpuinfo"] []- return $ maybe errMsg- (("Linux running on an "++) . drop 2 . dropWhile (/=':'))- (find (isPrefixOf "model name") $ lines info)- where- errMsg = "could not extract CPU model"- handler :: IOException -> IO String- handler _ = return errMsg---- | Get the path to the Html template file.-getHtmlTemplate :: IO FilePath-getHtmlTemplate = getDataFileName "HTML_TEMPLATE"----- | Build the command line corresponding to a program arguments tuple.-commandLine :: String -> [String] -> String-commandLine prog args = concat $ intersperse " " $ prog : args---- | Test if a process is executable and check its response. This is used to--- determine the versions and capabilities of tools that we depend on.-testProcess :: (String -> String -> Either String String) - -- ^ Analysis of stdout, stderr. Use 'Left' to report error.- -> String -- ^ Test description to display.- -> FilePath -- ^ Process to start- -> [String] -- ^ Arguments- -> String -- ^ Stdin- -> IO Bool -- ^ True, if test was successful-testProcess check testName prog args inp = do- putStr testName- hFlush stdout- handle handler $ do- (exitCode, out, err) <- readProcessWithExitCode prog args inp- let errMsg reason = do- putStrLn reason- putStrLn $ " command: " ++ commandLine prog args- putStrLn $ " stdin: " ++ inp- putStrLn $ " stdout: " ++ out- putStrLn $ " stderr: " ++ err- return False-- case exitCode of- ExitFailure code -> errMsg $ "failed with exit code " ++ show code- ExitSuccess -> - case check out err of- Left msg -> errMsg msg- Right msg -> do putStrLn msg- return True- where- handler :: IOException -> IO Bool- handler _ = do putStrLn "caught exception while executing:"- putStrLn $ commandLine prog args- putStrLn $ "with input: " ++ inp- return False---- | Ensure a suitable version of the Graphviz dot tool is installed.-ensureGraphVizDot :: Arguments -> IO ()-ensureGraphVizDot as = do- putStrLn $ "GraphViz tool: '" ++ dot ++ "'"- success <- testProcess check " checking version: " dot ["-V"] ""- unless success $ putStrLn errMsg- where- dot = dotPath as- check _ err- | "graphviz" `isInfixOf` map toLower err = Right $ init err ++ ". OK."- | otherwise = Left $ errMsg- errMsg = unlines- [ "WARNING:"- , ""- , " The dot tool seems not to be provided by Graphviz."- , " Graph generation might not work."- , " Please download an official version from:"- , " http://www.graphviz.org/"- ]---- | Ensure a suitable version of Maude is installed.-ensureMaude :: Arguments -> IO ()-ensureMaude as = do- putStrLn $ "maude tool: '" ++ maude ++ "'"- success <- testProcess check " checking version: " maude ["--version"] ""- unless success $ putStrLn $ errMsg "tool not found / does not work"- where- maude = maudePath as- check out _ - | filter (not . isSpace) out == "2.6" = Right "2.6. OK."- | otherwise = Left $ errMsg $- " 'maude --version' returned wrong verison '" ++ out ++ "'"-- errMsg reason = unlines- [ "WARNING:"- , ""- , reason- , " " ++ programName ++ " will likely not work."- , " Please download 'Core Maude 2.6' from:"- , " http://maude.cs.uiuc.edu/download/"- ]+main = M.main
+ src/Main/Console.hs view
@@ -0,0 +1,248 @@+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Support for interaction with the console: argument parsing.+module Main.Console (++ defaultMain++ -- * Static information about the Tamarin prover+ , programName++ -- * Constructing interaction modes for Tamarin prover+ , TamarinMode+ , tamarinMode++ , helpAndExit++ -- * Argument parsing+ , Arguments+ , ArgKey+ , ArgVal++ -- ** Setting arguments+ , updateArg+ , addEmptyArg++ , helpFlag++ -- ** Retrieving arguments+ , getArg+ , findArg+ , argExists++ -- * Pretty printing and console output+ , lineWidth+ , shortLineWidth++ , renderDoc+ ) where++import Safe+import Data.Maybe+import Data.Version (showVersion)+ +import Control.Monad+ +import System.FilePath+import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Text+import System.Exit++import qualified Text.PrettyPrint.Class as PP++import Paths_tamarin_prover++------------------------------------------------------------------------------+-- Static constants for the tamarin-prover+------------------------------------------------------------------------------++-- | Program name+programName :: String+programName = "tamarin-prover"++-- | Version string+versionStr :: FilePath -- ^ Path to LICENCE file.+ -> String+versionStr licensePath = unlines+ [ concat+ [ programName+ , " "+ , showVersion version+ , ", (C) Benedikt Schmidt, Simon Meier, ETH Zurich 2010-2012"+ ]+ , ""+ , "This program comes with ABSOLUTELY NO WARRANTY. It is free software, and you"+ , "are welcome to redistribute it according to its LICENSE, see"+ , "'" ++ licensePath ++ "'."+ ]++-- | Line width to use.+lineWidth :: Int+lineWidth = 110++shortLineWidth :: Int+shortLineWidth = 78+++------------------------------------------------------------------------------+-- A simple generic representation of arguments+------------------------------------------------------------------------------++-- | A name of an argument.+type ArgKey = String++-- | A value of an argument.+type ArgVal = String++-- | It is most convenient to view arguments just as 'String' based key-value+-- pairs. If there are multiple values for the same key, then the left-most+-- one is preferred.+type Arguments = [(ArgKey,ArgVal)]++-- | Does an argument exist.+argExists :: String -> Arguments -> Bool+argExists a = isJust . findArg a++-- | Find the value(s) corresponding to the given key.+findArg :: MonadPlus m => ArgKey -> Arguments -> m ArgVal+findArg a' as = msum [ return v | (a,v) <- as, a == a' ]++-- | Find the value corresponding to the given key. Throw an error if no value+-- exists.+getArg :: ArgKey -> Arguments -> ArgVal+getArg a = + fromMaybe (error $ "getArg: argument '" ++ a ++ "' not found") . findArg a++-- | Add an argument to the from of the list of arguments.+addArg :: ArgKey -> ArgVal -> Arguments -> Arguments+addArg a v = ((a,v):)++-- | Add an argument with the empty string as the value.+addEmptyArg :: String -> Arguments -> Arguments+addEmptyArg a = addArg a ""++-- | Update an argument.+updateArg :: ArgKey -> ArgVal -> Arguments -> Either a Arguments+updateArg a v = Right . addArg a v++-- | Add the help flag.+helpFlag :: Flag Arguments+helpFlag = flagHelpSimple (addEmptyArg "help")+++------------------------------------------------------------------------------+-- Modes for using the Tamarin prover+------------------------------------------------------------------------------++-- | A representation of an interaction mode with the Tamarin prover.+data TamarinMode = TamarinMode+ { tmName :: String+ , tmCmdArgsMode :: Mode Arguments+ -- ^ Run is given a reference to the mode. This enables changing the+ -- static information of a mode and keeping the same 'run' function.+ -- We use this for implementing the 'main' mode.+ , tmRun :: TamarinMode -> Arguments -> IO ()+ , tmIsMainMode :: Bool+ }++-- | Smart constructor for a 'TamarinMode'.+tamarinMode :: String -> Help + -> (Mode Arguments -> Mode Arguments) -- ^ Changes to default mode.+ -> (TamarinMode -> Arguments -> IO ()) + -> TamarinMode+tamarinMode name help adaptMode run0 = TamarinMode+ { tmName = name+ , tmCmdArgsMode = adaptMode $ Mode+ { modeGroupModes = toGroup []+ , modeNames = [name] + , modeValue = [] + , modeCheck = updateArg "mode" name+ , modeReform = const Nothing-- no reform possibility+ , modeHelp = help+ , modeHelpSuffix = []+ , modeArgs = ([], Nothing) -- no positional arguments+ , modeGroupFlags = toGroup [] -- no flags+ }+ , tmRun = run+ , tmIsMainMode = False+ }+ where+ run thisMode as + | argExists "help" as = helpAndExit thisMode Nothing+ | argExists "version" as = do licensePath <- getDataFileName "LICENSE"+ putStrLn $ versionStr licensePath+ | otherwise = run0 thisMode as+ +-- | Disply help message of a tamarin mode and exit.+helpAndExit :: TamarinMode -> Maybe String -> IO ()+helpAndExit tmode mayMsg = do+ putStrLn $ showText (Wrap lineWidth) + $ helpText header HelpFormatOne (tmCmdArgsMode tmode)+ -- output example info+ when (tmIsMainMode tmode) $ do+ examplePath <- getDataFileName "examples"+ manualPath <- getDataFileName "doc/MANUAL"+ let tutorialPath = examplePath </> "stable" </> "Tutorial.spthy"+ csf12Path = examplePath </> "csf12" </> "*.spthy"+ csf12Cmd = programName ++ " --prove -Ocase-studies +RTS -N -RTS " ++ csf12Path + csf12Cmd' = programName ++ " interactive +RTS -N -RTS " ++ csf12Path + separator = replicate shortLineWidth '-'+ e info paths = info ++ concatMap ("\n " ++) paths ++ "\n"+ putStrLn $ unlines + [ separator+ , e "For example protocol models see:" [examplePath]+ , e "A tutorial and the user manul are found at" [tutorialPath, manualPath]+ , e "To run all case-studies from our CSF'12 submission, use" [csf12Cmd]+ , e "To construct their security proofs interactively, use" [csf12Cmd']+ , "Note that the +RTS -N -RTS flags instruct the Haskell runtime system to"+ , "use as many cores as your system has. This speeds-up some of the computations."+ , separator+ ]+ end+ where+ (header, end) = case mayMsg of+ Nothing -> ([], return ())+ Just msg -> (["error: " ++ msg], exitFailure)++-- | Main function.+defaultMain :: TamarinMode -> [TamarinMode] -> IO ()+defaultMain firstMode otherModes = do+ as <- processArgs $ tmCmdArgsMode mainMode+ case findArg "mode" as of+ Nothing -> error $ "defaultMain: impossible - mode not set"+ Just name -> headNote "defaultMain: impossible - no mode found" $ do+ tmode <- (mainMode : otherModes)+ guard (tmName tmode == name)+ return $ tmRun tmode tmode as+ where+ mainMode = firstMode+ { tmName = programName+ , tmCmdArgsMode = (tmCmdArgsMode firstMode)+ { modeNames = [programName]+ , modeCheck = updateArg "mode" programName+ , modeGroupModes = toGroup (map tmCmdArgsMode $ otherModes) + , modeGroupFlags = (modeGroupFlags $ tmCmdArgsMode firstMode)+ { groupNamed =+ [ ("About"+ , [ helpFlag+ , flagVersion (addEmptyArg "version")+ ] )+ ]+ }+ }+ , tmIsMainMode = True+ }+++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------+ +-- | Render a pretty-printing document.+renderDoc :: PP.Doc -> String+renderDoc = PP.renderStyle (PP.defaultStyle { PP.lineLength = lineWidth })
+ src/Main/Environment.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Helpers for inspecting the environment of the Tamarin prover.+module Main.Environment where++import Data.List+import Data.Char (isSpace, toLower)+import Data.Maybe (fromMaybe)++import Control.Exception as E++import System.Console.CmdArgs.Explicit+import System.Exit+import System.Environment+import System.IO+import System.Process++import Paths_tamarin_prover++import Main.Console++------------------------------------------------------------------------------+-- Retrieving the paths to required tools.+------------------------------------------------------------------------------++-- | Flags for handing over the path to the maude and 'dot' tool.+toolFlags :: [Flag Arguments]+toolFlags = + [ flagOpt "dot" ["with-dot"] (updateArg "withDot") "FILE" "Path to GraphViz 'dot' tool"+ , flagOpt "maude" ["with-maude"] (updateArg "withMaude") "FILE" "Path to 'maude' rewriting tool"+ ]++-- | Path to maude tool+maudePath :: Arguments -> FilePath+maudePath = fromMaybe "maude" . findArg "withMaude"++-- | Path to dot tool+dotPath :: Arguments -> FilePath+dotPath = fromMaybe "dot" . findArg "withDot"+++------------------------------------------------------------------------------+-- Inspecting the environment+------------------------------------------------------------------------------++-- | Get the string constituting the command line.+getCommandLine :: IO String+getCommandLine = do+ arguments <- getArgs+ return . concat . intersperse " " $ programName : arguments++-- | Read the cpu info using a call to cat /proc/cpuinfo+getCpuModel :: IO String+getCpuModel = + handle handler $ do+ (_, info, _) <- readProcessWithExitCode "cat" ["/proc/cpuinfo"] []+ return $ maybe errMsg+ (("Linux running on an "++) . drop 2 . dropWhile (/=':'))+ (find (isPrefixOf "model name") $ lines info)+ where+ errMsg = "could not extract CPU model"+ handler :: IOException -> IO String+ handler _ = return errMsg++-- | Get the path to the Html template file.+getHtmlTemplate :: IO FilePath+getHtmlTemplate = getDataFileName "HTML_TEMPLATE"+++-- | Build the command line corresponding to a program arguments tuple.+commandLine :: String -> [String] -> String+commandLine prog args = concat $ intersperse " " $ prog : args++-- | Test if a process is executable and check its response. This is used to+-- determine the versions and capabilities of tools that we depend on.+testProcess :: (String -> String -> Either String String, String)+ -- ^ Analysis of stdout, stderr. Use 'Left' to report error.+ -> String -- ^ Test description to display.+ -> FilePath -- ^ Process to start+ -> [String] -- ^ Arguments+ -> String -- ^ Stdin+ -> IO Bool -- ^ True, if test was successful+testProcess (check, defaultMsg) testName prog args inp = do+ putStr testName+ hFlush stdout+ handle handler $ do+ (exitCode, out, err) <- readProcessWithExitCode prog args inp+ let errMsg reason = do+ putStrLn reason+ putStrLn $ "Detailed results from testing '" ++ prog ++ "'"+ putStrLn $ " command: " ++ commandLine prog args+ putStrLn $ " stdin: " ++ inp+ putStrLn $ " stdout: " ++ out+ putStrLn $ " stderr: " ++ err+ return False++ case exitCode of+ ExitFailure code -> errMsg $ + "failed with exit code " ++ show code ++ "\n\n" ++ defaultMsg+ ExitSuccess -> + case check out err of+ Left msg -> errMsg msg+ Right msg -> do putStrLn msg+ return True+ where+ handler :: IOException -> IO Bool+ handler _ = do putStrLn "caught exception while executing:"+ putStrLn $ commandLine prog args+ putStrLn $ "with input: " ++ inp+ return False++-- | Ensure a suitable version of the Graphviz dot tool is installed.+ensureGraphVizDot :: Arguments -> IO Bool+ensureGraphVizDot as = do+ putStrLn $ "GraphViz tool: '" ++ dot ++ "'"+ testProcess (check, errMsg) " checking version: " dot ["-V"] ""+ where+ dot = dotPath as+ check _ err+ | "graphviz" `isInfixOf` map toLower err = Right $ init err ++ ". OK."+ | otherwise = Left $ errMsg+ errMsg = unlines+ [ "WARNING:"+ , ""+ , " The dot tool seems not to be provided by Graphviz."+ , " Graph generation might not work."+ , " Please download an official version from:"+ , " http://www.graphviz.org/"+ ]++-- | Ensure a suitable version of Maude is installed.+ensureMaude :: Arguments -> IO Bool+ensureMaude as = do+ putStrLn $ "maude tool: '" ++ maude ++ "'"+ testProcess (check, errMsg') " checking version: " maude ["--version"] ""+ where+ maude = maudePath as+ check out _ + | filter (not . isSpace) out == "2.6" = Right "2.6. OK."+ | otherwise = Left $ errMsg $+ " 'maude --version' returned wrong verison '" ++ out ++ "'"++ errMsg' = errMsg $ "'" ++ maude ++ "' executable not found / does not work"+ errMsg reason = unlines+ [ "WARNING:"+ , ""+ , reason+ , " " ++ programName ++ " will likely not work."+ , " Please download 'Core Maude 2.6' from:"+ , " http://maude.cs.uiuc.edu/download/"+ ]
+ src/Main/Mode/Batch.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Main module for the Tamarin prover.+module Main.Mode.Batch (+ batchMode+ ) where++import Data.List+import Data.Maybe+import Control.Basics+import System.Console.CmdArgs.Explicit as CmdArgs+import System.FilePath+import System.Timing (timed)++import qualified Text.PrettyPrint.Class as Pretty++import Theory++import Main.Utils+import Main.Console+import Main.Environment+import Main.TheoryLoader+++-- | Batch processing mode.+batchMode :: TamarinMode+batchMode = tamarinMode + "batch" + "Security protocol analysis and verification."+ setupFlags+ run+ where+ setupFlags defaultMode = defaultMode+ { modeArgs = ([], Just $ flagArg (updateArg "inFile") "FILES")+ , modeGroupFlags = Group + { groupUnnamed =+ theoryLoadFlags +++ -- [ flagNone ["html"] (addEmptyArg "html")+ -- "generate HTML visualization of proofs"++ [ flagNone ["no-compress"] (addEmptyArg "noCompress")+ "Do not use compressed sequent visualization"++ , flagNone ["parse-only"] (addEmptyArg "parseOnly")+ "Just parse the input file and pretty print it as-is"+ ] +++ outputFlags +++ toolFlags + , groupHidden = []+ , groupNamed = []+ }+ }++ outputFlags = + [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file"+ , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR" "Output directory"+ ]++-- | Process a theory file.+run :: TamarinMode -> Arguments -> IO ()+run thisMode as + | null inFiles = helpAndExit thisMode (Just "no input files given")+ | otherwise = do+ _ <- ensureMaude as+ putStrLn $ ""+ summaries <- mapM processThy $ inFiles+ putStrLn $ ""+ putStrLn $ replicate 78 '='+ putStrLn $ "summary of summaries:"+ putStrLn $ ""+ putStrLn $ renderDoc $ Pretty.vcat $ intersperse (Pretty.text "") summaries+ putStrLn $ ""+ putStrLn $ replicate 78 '='+ where+ -- handles to arguments+ -----------------------+ inFiles = reverse $ findArg "inFile" as++ -- output generation+ --------------------++ dryRun = not (argExists "outFile" as || argExists "outDir" as)++ mkOutPath :: FilePath -- ^ Input file name.+ -> FilePath -- ^ Output file name.+ mkOutPath inFile = + fromMaybe (error "please specify an output file or directory") $+ do outFile <- findArg "outFile" as+ guard (outFile /= "")+ return outFile+ <|>+ do outDir <- findArg "outDir" as+ return $ mkAutoPath outDir (takeBaseName inFile)++ -- automatically generate the filename for output+ mkAutoPath :: FilePath -> String -> FilePath+ mkAutoPath dir baseName+ | argExists "html" as = dir </> baseName+ | otherwise = dir </> addExtension (baseName ++ "_analyzed") "spthy"++ -- theory processing functions+ ------------------------------++ processThy :: FilePath -> IO (Pretty.Doc)+ processThy inFile + -- | argExists "html" as = + -- generateHtml inFile =<< loadClosedThy as inFile+ | argExists "parseOnly" as =+ out (const Pretty.emptyDoc) prettyOpenTheory (loadOpenThy as inFile)+ | otherwise = + out prettyClosedSummary prettyClosedTheory (loadClosedThy as inFile)+ where+ ppAnalyzed = Pretty.text $ "analyzed: " ++ inFile++ out :: (a -> Pretty.Doc) -> (a -> Pretty.Doc) -> IO a -> IO Pretty.Doc+ out summaryDoc fullDoc load+ | dryRun = do+ thy <- load+ putStrLn $ renderDoc $ fullDoc thy+ return $ ppAnalyzed Pretty.$--$ Pretty.nest 2 (summaryDoc thy)+ | otherwise = do+ putStrLn $ ""+ putStrLn $ "analyzing: " ++ inFile+ putStrLn $ ""+ let outFile = mkOutPath inFile+ (thySummary, t) <- timed $ do+ thy <- load+ writeFileWithDirs outFile $ renderDoc $ fullDoc thy+ return $ summaryDoc thy+ let summary = Pretty.vcat+ [ ppAnalyzed+ , Pretty.text $ ""+ , Pretty.text $ " output: " ++ outFile+ , Pretty.text $ " processing time: " ++ show t+ , Pretty.text $ ""+ , Pretty.nest 2 thySummary+ ]+ putStrLn $ replicate 78 '-'+ putStrLn $ renderDoc summary+ putStrLn $ ""+ putStrLn $ replicate 78 '-'+ return summary++ {- TO BE REACTIVATED once infrastructure from interactive mode can be used++ -- static html generation+ -------------------------++ generateHtml :: FilePath -- ^ Input file+ -> ClosedTheory -- ^ Theory to pretty print+ -> IO ()+ generateHtml inFile thy = do+ cmdLine <- getCommandLine+ time <- getCurrentTime+ cpu <- getCpuModel+ template <- getHtmlTemplate+ theoryToHtml $ GenerationInput {+ giHeader = "Generated by " ++ htmlVersionStr+ , giTime = time+ , giSystem = cpu+ , giInputFile = inFile+ , giTemplate = template+ , giOutDir = mkOutPath inFile+ , giTheory = thy+ , giCmdLine = cmdLine+ , giCompress = not $ argExists "noCompress" as+ }++ -}
+ src/Main/Mode/Interactive.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Main module for the Tamarin prover.+module Main.Mode.Interactive (+ interactiveMode+ ) where++import Data.List+import Data.Maybe+import Control.Basics+import System.Console.CmdArgs.Explicit as CmdArgs+import System.FilePath+import System.Directory (doesFileExist, doesDirectoryExist)++import Web.Dispatch+import qualified Web.Settings+import qualified Network.Wai.Handler.Warp as Warp+import Network.Wai.Handler.Warp (defaultSettings, settingsHost+ , settingsPort, HostPreference(Host))++import Main.Console+import Main.Environment+import Main.TheoryLoader++import Paths_tamarin_prover (getDataDir)+++-- | Batch processing mode.+interactiveMode :: TamarinMode+interactiveMode = tamarinMode + "interactive"+ "Start a web-server to construct proofs interactively."+ setupFlags+ run+ where+ setupFlags defaultMode = defaultMode+ { modeArgs = ([], Just $ flagArg (updateArg "workDir") "WORKDIR")+ , modeCheck = updateArg "mode" "interactive"+ , modeGroupFlags = Group interactiveFlags [] [("About", [helpFlag])]+ }++ interactiveFlags =+ [ flagOpt "" ["port","p"] (updateArg "port") "PORT" "Port to listen on"+ -- , flagOpt "" ["datadir"] (updateArg "datadir") "DATADIR" "Directory with data"+ , flagNone ["debug"] (addEmptyArg "debug") "Show server debugging output"+ -- , flagNone ["autosave"] (addEmptyArg "autosave") "Automatically save proof state"+ -- , flagNone ["loadstate"] (addEmptyArg "loadstate") "Load proof state if present"+ ] +++ theoryLoadFlags +++ toolFlags++ ++-- | Start the interactive theorem proving mode.+run :: TamarinMode -> Arguments -> IO ()+run thisMode as = case findArg "workDir" as of+ Nothing -> helpAndExit thisMode+ (Just "no working directory specified")+ Just workDir0 -> do+ -- determine working directory+ wdIsFile <- doesFileExist workDir0+ let workDir | wdIsFile = takeDirectory workDir0+ | otherwise = workDir0+ wdIsDir <- doesDirectoryExist workDir+ if wdIsDir+ then do+ -- process theories+ _ <- ensureGraphVizDot as+ _ <- ensureMaude as+ putStrLn ""+ port <- readPort+ dataDir <- readDataDir+ let serverUrl = "http://127.0.0.1:" ++ show port + putStrLn $ intercalate "\n"+ [ "The server is starting up on port " ++ show port ++ "."+ , "Browse to " ++ serverUrl ++ " once the server is ready."+ , ""+ , "Loading the security protocol theories '" ++ workDir </> "*.spthy" ++ "' ..."+ ]+ withWebUI + ("Finished loading theories ... server ready at \n\n " ++ serverUrl ++ "\n")+ workDir (argExists "loadstate" as) (argExists "autosave" as)+ (loadClosedWfThy as) (loadClosedThyString as) (closeThy as)+ (argExists "debug" as) dataDir+ (Warp.runSettings+ (defaultSettings { settingsHost = Host "127.0.0.1",+ settingsPort = port}))+ else + helpAndExit thisMode+ (Just $ "directory '" ++ workDir ++ "' does not exist.")+ where+ -- Datadir argument+ readDataDir =+ case findArg "datadir" as of+ [d] -> return d+ _ -> getDataDir++ -- Port argument+ ----------------+ readPort = do+ let port = findArg "port" as >>= fmap fst . listToMaybe . reads+ when+ (argExists "port" as && isNothing port) + (putStrLn $ "Unable to read port from argument `"+ ++fromMaybe "" (findArg "port" as)++"'. Using default.")+ return $ fromMaybe Web.Settings.defaultPort port
+ src/Main/Mode/Intruder.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Main module for the Tamarin prover.+module Main.Mode.Intruder (+ intruderMode+ ) where++import Control.Basics+import Control.Monad.Reader++import System.Console.CmdArgs.Explicit as CmdArgs+import System.FilePath++import Theory++import Main.Console+import Main.Environment+import Main.TheoryLoader (intruderVariantsFile)+import Main.Utils+++intruderMode :: TamarinMode+intruderMode = tamarinMode + "variants" + "Compute the variants of the intruder rules for DH-exponentiation."+ setupFlags+ run+ where+ setupFlags defaultMode = defaultMode+ { modeArgs = ([], Nothing ) -- no positional argumants+ , modeGroupFlags = Group outputFlags [] [("About", [helpFlag])]+ }++ outputFlags = + [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file"+ , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR" "Output directory"+ ]++-- | Compute the intruder variants.+run :: TamarinMode -> Arguments -> IO ()+run _thisMode as = do+ _ <- ensureMaude as+ hnd <- startMaude (maudePath as) dhMaudeSig+ let rules = dhIntruderRules `runReader` hnd+ rulesString = renderDoc $ prettyIntruderVariants rules+ putStrLn rulesString+ writeRules rulesString+ where+ -- output generation+ --------------------++ writeRules rulesString = case optOutPath of+ Just outPath -> writeFileWithDirs outPath rulesString+ Nothing -> return ()++ -- Output file name, if output is desired.+ optOutPath :: Maybe FilePath+ optOutPath = + do outFile <- findArg "outFile" as+ guard (outFile /= "")+ return outFile+ <|>+ do outDir <- findArg "outDir" as+ return $ outDir </> intruderVariantsFile
+ src/Main/Mode/Test.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Self-test mode for the Tamarin prover.+module Main.Mode.Test (+ testMode+ ) where++import System.Console.CmdArgs.Explicit as CmdArgs+import System.Exit+import Test.HUnit (Counts(..))++import Main.Console+import Main.Environment++import qualified Term.UnitTests as TestTerm (main)+++-- | Self-test mode.+testMode :: TamarinMode+testMode = tamarinMode + "test" + ("Self-test the " ++ programName ++ " installation.")+ setupFlags+ run+ where+ setupFlags defaultMode = defaultMode+ { modeArgs = ([], Just $ flagArg (updateArg "inFile") "FILES")+ , modeGroupFlags = Group + { groupUnnamed = toolFlags + , groupHidden = []+ , groupNamed = [("About", [helpFlag])]+ }+ }++-- | Run the self-test.+run :: TamarinMode -> Arguments -> IO ()+run _thisMode as = do+ putStrLn $ "Self-testing the " ++ programName ++ " installation." + nextTopic "Testing the availability of the required tools"+ successMaude <- ensureMaude as+#ifndef NO_GUI+ putStrLn ""+ successGraphVizDot <- ensureGraphVizDot as+#else+ let successGraphVizDot = True+#endif+ nextTopic "Testing the unification infrastructure"+ Counts _ _ termErrs termFails <- TestTerm.main (maudePath as)+ let successTerm = termErrs == 0 && termFails == 0+ success = and [successMaude, successGraphVizDot, successTerm]++ -- FIXME: Implement regression testing.+ --+ nextTopic "TEST SUMMARY"+ if success+ then do putStrLn $ "All tests successful."+ putStrLn $ "The " ++ programName ++ " should work as intended."+ putStrLn $ "\n :-) happy proving (-:\n"+ exitSuccess+ else do putStrLn $ "\nWARNING: Some tests failed."+ putStrLn $ "The " ++ programName ++ " might NOT WORK AS INTENDED.\n"+ exitFailure+ where+ nextTopic msg = putStrLn $ "\n*** " ++ msg ++ " ***"
+ src/Main/TheoryLoader.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Theory loading infrastructure.+module Main.TheoryLoader (+ -- * Static theory loading settings+ intruderVariantsFile+ , theoryLoadFlags++ -- ** Loading open theories+ , loadOpenThy++ -- ** Loading and closing theories+ , loadClosedThy+ , loadClosedWfThy+ , loadClosedThyString++ , closeThy++ ) where++import Prelude hiding (id, (.))++import Data.Monoid+import Data.Char (toLower)+import Data.Label++import Control.Basics+import Control.Category++import System.Console.CmdArgs.Explicit+import System.Directory++import Extension.Prelude++import Theory+import Theory.Parser+import Theory.Wellformedness+import Theory.AbstractInterpretation (EvaluationStyle(..))++import Main.Console+import Main.Environment++import Paths_tamarin_prover (getDataFileName)+++------------------------------------------------------------------------------+-- Theory loading: shared between interactive and batch mode+------------------------------------------------------------------------------++-- | The name of the intruder variants file.+intruderVariantsFile :: FilePath+intruderVariantsFile = "intruder_variants_dh.spthy"+++-- | Flags for loading a theory.+theoryLoadFlags :: [Flag Arguments]+theoryLoadFlags = + [ flagNone ["prove"] (addEmptyArg "addProofs")+ "Attempt to prove all security properties"++ , flagOpt "dfs" ["stop-on-trace"] (updateArg "stopOnTrace") "DFS|BFS|NONE"+ "How to search for traces (default DFS)"++ , flagOpt "5" ["bound", "b"] (updateArg "bound") "INT"+ "Bound the depth of the proofs"++ --, flagOpt "" ["intruder","i"] (updateArg "intruderVariants") "FILE"+ -- "Cached intruder rules to use"++ , flagOpt "summary" ["partial-evaluation"] (updateArg "partialEvaluation")+ "SUMMARY|VERBOSE"+ "Partially evaluate multiset rewriting system"++ , flagOpt "" ["defines","D"] (updateArg "defines") "STRING"+ "Define flags for pseudo-preprocessor."+ ]++loadOpenThy :: Arguments -> FilePath -> IO OpenTheory+loadOpenThy = fst . loadThy++loadClosedThy :: Arguments -> FilePath -> IO ClosedTheory+loadClosedThy = uncurry (>=>) . loadThy++loadClosedWfThy :: Arguments -> FilePath -> IO ClosedTheory+loadClosedWfThy as file = do+ thy <- loadOpen file+ case checkWellformedness thy of+ [] -> close thy+ report -> do + putStrLn $ "WARNING: ignoring the following errors"+ putStrLn $ renderDoc $ prettyWfErrorReport report+ close thy+ -- report -> error $ renderDoc $ prettyWfErrorReport report+ where+ (loadOpen, close) = loadThy as++loadClosedThyString :: Arguments -> String -> IO ClosedTheory+loadClosedThyString = uncurry (>=>) . loadThyString++-- | Load an open/closed theory from a file.+loadThy :: Arguments -> (FilePath -> IO OpenTheory, OpenTheory -> IO ClosedTheory)+loadThy as = loadGenericThy (parseOpenTheory (defines as)) as ++-- | Load an open/closed theory from a string.+loadThyString :: Arguments -> (String -> IO OpenTheory, OpenTheory -> IO ClosedTheory)+loadThyString as = loadGenericThy loader as+ where+ loader str =+ case parseOpenTheoryString (defines as) str of+ Right thy -> return thy+ Left err -> error $ show err ++-- | The defined pre-processor flags in the argument.+defines :: Arguments -> [String]+defines = findArg "defines"++-- | Load an open/closed theory given a loader function.+loadGenericThy :: (a -> IO OpenTheory)+ -> Arguments + -> (a -> IO OpenTheory, OpenTheory -> IO ClosedTheory)+loadGenericThy loader as =+ (loader, (closeThy as) <=< tryAddIntrVariants)+ where+ -- intruder variants+ --------------------+ tryAddIntrVariants :: OpenTheory -> IO OpenTheory+ tryAddIntrVariants thy0 = do+ let msig = get (sigpMaudeSig . thySignature) thy0+ thy = addIntrRuleACs (subtermIntruderRules msig ++ specialIntruderRules) thy0+ if (enableDH msig) then+ do variantsFile <- getDataFileName intruderVariantsFile+ ifM (doesFileExist variantsFile)+ (do intrVariants <- parseIntruderRulesDH variantsFile+ return $ addIntrRuleACs intrVariants thy+ )+ (error $ "could not find intruder message deduction theory '" + ++ variantsFile ++ "'")+ else return thy++-- | Close a theory according to arguments.+closeThy :: Arguments -> OpenTheory -> IO ClosedTheory+closeThy as = + fmap (proveTheory prover . partialEvaluation) + . closeTheory (maudePath as)+ -- FIXME: wf-check is at the wrong position here. Needs to be more+ -- fine-grained.+ . wfCheck + where+ -- handles to relevant arguments+ --------------------------------+ proofBound = read <$> findArg "bound" as+ requireProofs = argExists "addProofs" as++ stopOnTrace :: Maybe String+ stopOnTrace = findArg "stopOnTrace" as++ -- apply partial application+ ----------------------------+ partialEvaluation = case map toLower <$> findArg "partialEvaluation" as of+ Just "verbose" -> applyPartialEvaluation Tracing+ Just _ -> applyPartialEvaluation Summary+ _ -> id++ -- wellformedness check+ -----------------------+ wfCheck :: OpenTheory -> OpenTheory+ wfCheck thy = + noteWellformedness+ (checkWellformedness thy) thy++ -- protocol transformation+ --------------------------+ prover :: Prover+ prover + | requireProofs = cutAttack $ maybe id boundProver proofBound autoProver+ | otherwise = mempty+ where + cutAttack = mapProverProof $ case map toLower <$> stopOnTrace of+ Nothing -> cutOnAttackDFS+ Just "dfs" -> cutOnAttackDFS+ Just "none" -> id+ Just "bfs" -> cutOnAttackBFS+ Just other -> error $ "unknown stop-on-trace method: " ++ other+
+ src/Main/Utils.hs view
@@ -0,0 +1,28 @@+-- |+-- Copyright : (c) 2012 Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+--+-- Various utility functions for interacting with the user.+module Main.Utils (+ -- * File handling+ writeFileWithDirs++ ) where+++import System.FilePath+import System.Directory+++------------------------------------------------------------------------------+-- File Handling+------------------------------------------------------------------------------++-- | Write a file and ensure that its containing directory exists.+writeFileWithDirs :: FilePath -> String -> IO ()+writeFileWithDirs file output = do+ createDirectoryIfMissing True (takeDirectory file)+ writeFile file output+
+ src/Main_Full.hs view
@@ -0,0 +1,18 @@+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Main module for the Tamarin prover without a GUI.+module Main_Full where++import Main.Console (defaultMain)+import Main.Mode.Batch (batchMode)+import Main.Mode.Intruder (intruderMode)+import Main.Mode.Interactive (interactiveMode)+import Main.Mode.Test (testMode)++main :: IO ()+main = defaultMain batchMode [interactiveMode, intruderMode, testMode]
+ src/Main_NoGui.hs view
@@ -0,0 +1,17 @@+-- |+-- Copyright : (c) 2010, 2011 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Main module for the Tamarin prover without a GUI+module Main_NoGui where++import Main.Console (defaultMain)+import Main.Mode.Batch (batchMode)+import Main.Mode.Intruder (intruderMode)+import Main.Mode.Test (testMode)++main :: IO ()+main = defaultMain batchMode [intruderMode, testMode]
src/Theory.hs view
@@ -11,8 +11,10 @@ module Theory ( -- * Lemmas LemmaAttribute(..)- , Lemma(..)+ , TraceQuantifier(..)+ , Lemma , lName+ , lTraceQuantifier , lFormulaE , lFormulaAC , lAttributes@@ -27,6 +29,7 @@ , thySignature , thyCache , thyItems+ , theoryRules , addLemma , removeLemma , lookupLemma@@ -38,9 +41,9 @@ -- ** Open theories , OpenTheory , defaultOpenTheory- , dhIntruderTheory , addProtoRule , addIntrRuleACs+ , applyPartialEvaluation -- ** Closed theories , ClosedTheory@@ -76,6 +79,9 @@ , prettyClosedSummary + , prettyIntruderVariants+ , prettyTraceQuantifier+ -- * Convenience exports , module Theory.Proof , module Theory.IntruderRules@@ -103,13 +109,13 @@ import qualified Extension.Data.Label as L import Extension.Data.Label hiding (get) -import Text.Isar- import Theory.Pretty import Theory.Rule+import Theory.RuleSet import Theory.RuleVariants import Theory.IntruderRules import Theory.Proof+import Theory.AbstractInterpretation ------------------------------------------------------------------------------@@ -153,7 +159,7 @@ { _cprRuleE :: ProtoRuleE -- original rule modulo E , _cprRuleAC :: ProtoRuleAC -- variant modulo AC }- deriving( Show )+ deriving( Eq, Ord, Show ) type OpenRuleCache = [IntrRuleAC] @@ -203,7 +209,8 @@ closeRuleCache typingAsms sig protoRules intrRulesAC = ClosedRuleCache classifiedRules untypedCaseDists typedCaseDists where- ctxt0 = ProofContext sig classifiedRules []+ ctxt0 = ProofContext sig classifiedRules UntypedCaseDist [] AvoidInduction+ (error "closeRuleCache: trace quantifier should not matter here") -- precomputing the case distinctions untypedCaseDists = precomputeCaseDistinctions ctxt0 [] typedCaseDists = @@ -215,18 +222,14 @@ anyOf ps = partition (\x -> any ($ x) ps) - (nonProto, proto) = - anyOf [ isDestrRule, isConstrRule , isFreshRule, isIRecvRule] rulesAC- (spec, nonSpec) = anyOf [isIRecvRule, isFreshRule] nonProto- (constr, destr) = anyOf [isConstrRule] nonSpec- -- FIXME: Learn, knows, fresh, etc. are special rules+ (nonProto, proto) = anyOf [isDestrRule, isConstrRule] rulesAC+ (constr, destr) = anyOf [isConstrRule] nonProto -- and sort them into ClassifiedRules datastructure for later use in proofs classifiedRules = ClassifiedRules { _crConstruct = constr , _crDestruct = destr , _crProtocol = proto- , _crSpecial = spec } @@ -235,21 +238,28 @@ -- Lemmas ------------------------------------------------------------------------------ +-- | An attribute for a 'Lemma'. data LemmaAttribute = TypingLemma | ReuseLemma+ | InvariantLemma deriving( Eq, Ord, Show ) +-- | A 'TraceQuantifier' stating whether we check satisfiability of validity.+data TraceQuantifier = ExistsTrace | AllTraces+ deriving( Eq, Ord, Show )+ -- | A lemma describes a property that holds in the context of a theory -- together with a proof of its correctness. data Lemma p = Lemma- { _lName :: String- , _lFormulaE :: FormulaE- , _lFormulaAC :: Maybe FormulaAC- , _lAttributes :: [LemmaAttribute]- , _lProof :: p+ { _lName :: String+ , _lTraceQuantifier :: TraceQuantifier+ , _lFormulaE :: FormulaE+ , _lFormulaAC :: Maybe FormulaAC+ , _lAttributes :: [LemmaAttribute]+ , _lProof :: p }- deriving( Show )+ deriving( Eq, Ord, Show ) $(mkLabels [''Lemma]) @@ -258,31 +268,47 @@ ------------ instance Functor Lemma where- fmap f (Lemma n fE fAC atts prf) = Lemma n fE fAC atts (f prf)+ fmap f (Lemma n qua fE fAC atts prf) = Lemma n qua fE fAC atts (f prf) instance Foldable Lemma where foldMap f = f . L.get lProof instance Traversable Lemma where- traverse f (Lemma n fE fAC atts prf) = Lemma n fE fAC atts <$> f prf+ traverse f (Lemma n qua fE fAC atts prf) = Lemma n qua fE fAC atts <$> f prf +-- Lemma queries+----------------------------------++-- | Convert a trace quantifier to a sequent trace quantifier.+toSequentTraceQuantifier :: TraceQuantifier -> SequentTraceQuantifier+toSequentTraceQuantifier AllTraces = ExistsNoTrace+toSequentTraceQuantifier ExistsTrace = ExistsSomeTrace++-- | True iff the lemma can be used as a typing lemma.+isTypingLemma :: Lemma p -> Bool+isTypingLemma lem =+ (AllTraces == L.get lTraceQuantifier lem)+ && (TypingLemma `elem` L.get lAttributes lem)++ -- Lemma construction/modification ---------------------------------- -- | Create a new unproven lemma from a formula modulo E.-unprovenLemma :: String -> [LemmaAttribute] -> FormulaE -> Lemma ProofSkeleton-unprovenLemma name atts fmE = Lemma name fmE Nothing atts (unproven ())+unprovenLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> FormulaE+ -> Lemma ProofSkeleton+unprovenLemma name atts qua fmE = Lemma name qua fmE Nothing atts (unproven ()) -skeletonLemma :: String -> [LemmaAttribute] -> FormulaE+skeletonLemma :: String -> [LemmaAttribute] -> TraceQuantifier -> FormulaE -> ProofSkeleton -> Lemma ProofSkeleton-skeletonLemma name atts fmE = Lemma name fmE Nothing atts+skeletonLemma name atts qua fmE = Lemma name qua fmE Nothing atts -- | The case-distinction kind allowed for a lemma lemmaCaseDistKind :: Lemma p -> CaseDistKind lemmaCaseDistKind lem | TypingLemma `elem` L.get lAttributes lem = UntypedCaseDist- | otherwise = TypedCaseDist+ | otherwise = TypedCaseDist ------------------------------------------------------------------------------@@ -297,7 +323,7 @@ RuleItem r | LemmaItem (Lemma p) | TextItem FormalComment- deriving( Show, Functor )+ deriving( Show, Eq, Ord, Functor ) -- | A theory contains a single set of rewriting rules modeling a protocol@@ -391,13 +417,6 @@ defaultOpenTheory :: OpenTheory defaultOpenTheory = Theory "default" emptySignaturePure [] [] --- | The default intruder theory; uses Maude to perform AC--- unification for computing the variants.-dhIntruderTheory :: MaudeHandle -> OpenTheory-dhIntruderTheory hnd =- Theory "intruder_variants" (emptySignaturePure { _sigMaudeInfo = dhMaudeSig })- (dhIntruderRules `runReader` hnd) []- -- | Open a theory by dropping the closed world assumption and values whose -- soundness dependens on it. openTheory :: ClosedTheory -> OpenTheory@@ -443,14 +462,21 @@ getProtoRuleEs = map openProtoRule . theoryRules -- | Get the proof context for a lemma of the closed theory.-getProofContext :: CaseDistKind -> ClosedTheory -> ProofContext-getProofContext kind thy = ProofContext+getProofContext :: Lemma a -> ClosedTheory -> ProofContext+getProofContext l thy = ProofContext ( L.get thySignature thy) ( L.get (crcRules . thyCache) thy)+ kind ( L.get (cases . thyCache) thy)+ inductionHint+ (toSequentTraceQuantifier $ L.get lTraceQuantifier l) where- cases = case kind of UntypedCaseDist -> crcUntypedCaseDists- TypedCaseDist -> crcTypedCaseDists+ kind = lemmaCaseDistKind l+ cases = case kind of UntypedCaseDist -> crcUntypedCaseDists+ TypedCaseDist -> crcTypedCaseDists+ inductionHint+ | any (`elem` [TypingLemma, InvariantLemma]) (L.get lAttributes l) = UseInduction+ | otherwise = AvoidInduction -- | The classified set of rules modulo AC in this theory. getClassifiedRules :: ClosedTheory -> ClassifiedRules@@ -465,6 +491,10 @@ -- construction --------------- +-- -- | Convert a lemma to the corresponding guarded formula.+-- lemmaToGuarded :: Lemma p -> Maybe LNGuarded+-- lemmaToGuarded lem = + -- | Close a theory by closing its associated rule set and converting the proof -- skeletons to unannotated incremental proofs and caching AC variants as well -- as precomputed case distinctions.@@ -477,47 +507,100 @@ -> IO ClosedTheory closeTheory maudePath thy0 = do sig <- toSignatureWithMaude maudePath $ L.get thySignature thy0- let cache = closeRuleCache typAsms sig rules $ L.get thyCache thy0- addSorrys = checkAndExtendProver (sorryProver "not yet proven")+ return $ closeTheoryWithMaude sig thy0 - -- Maude / Signature handle- hnd = L.get sigmMaudeHandle sig+-- | Close a theory given a maude signature. This signature must be valid for+-- the given theory.+closeTheoryWithMaude :: SignatureWithMaude -> OpenTheory -> ClosedTheory+closeTheoryWithMaude sig thy0 = do+ proveTheory addSorrys $ Theory (L.get thyName thy0) sig cache items+ where+ cache = closeRuleCache typAsms sig rules $ L.get thyCache thy0+ addSorrys = checkAndExtendProver (sorryProver "not yet proven") - -- close all theory items: in parallel- items = (closeTheoryItem <$> L.get thyItems thy0) `using` parList rdeepseq- closeTheoryItem = foldTheoryItem - (RuleItem . closeProtoRule hnd) - (LemmaItem . ensureFormulaAC . fmap skeletonToIncrementalProof)- TextItem+ -- Maude / Signature handle+ hnd = L.get sigmMaudeHandle sig - -- extract typing lemmas- typAsms = do - LemmaItem lem <- items- guard (TypingLemma `elem` L.get lAttributes lem)- let toGuarded = fmap negateGuarded . fromFormulaNegate- case toGuarded <$> L.get lFormulaAC lem of- Just (Right gf) -> return gf- Just (Left err) -> error $ "closeTheory: " ++ err- _ -> mzero+ -- close all theory items: in parallel+ (items, _solveRel, _breakers) = (`runReader` hnd) $ addSolvingLoopBreakers+ ((closeTheoryItem <$> L.get thyItems thy0) `using` parList rdeepseq)+ closeTheoryItem = foldTheoryItem + (RuleItem . closeProtoRule hnd) + (LemmaItem . ensureFormulaAC . fmap skeletonToIncrementalProof)+ TextItem - -- extract protocol rules- rules = theoryRules (Theory errClose errClose errClose items)- errClose = error "closeTheory"+ -- extract typing lemmas+ typAsms = do + LemmaItem lem <- items+ guard (isTypingLemma lem) + let toGuarded = fmap negateGuarded . fromFormulaNegate+ case toGuarded <$> L.get lFormulaAC lem of+ Just (Right gf) -> return gf+ Just (Left err) -> error $ "closeTheory: " ++ err+ _ -> mzero - return $ proveTheory addSorrys $ Theory (L.get thyName thy0) sig cache items+ -- extract protocol rules+ rules = theoryRules (Theory errClose errClose errClose items)+ errClose = error "closeTheory" + addSolvingLoopBreakers = useAutoLoopBreakersAC+ (liftToItem $ enumPrems . L.get cprRuleAC)+ (liftToItem $ enumConcs . L.get cprRuleAC)+ (liftToItem $ getDisj . L.get (pracVariants . rInfo . cprRuleAC))+ addBreakers+ where+ liftToItem f (RuleItem ru) = f ru+ liftToItem _ _ = [] + addBreakers bs (RuleItem ru) = + RuleItem (L.set (pracLoopBreakers . rInfo . cprRuleAC) bs ru)+ addBreakers _ item = item++++-- Partial evaluation / abstract interpretation+-----------------------------------------------++-- | Apply partial evaluation.+applyPartialEvaluation :: EvaluationStyle -> ClosedTheory -> ClosedTheory+applyPartialEvaluation evalStyle thy0 =+ closeTheoryWithMaude sig $+ L.modify thyItems replaceProtoRules (openTheory thy0)+ where+ sig = L.get thySignature thy0+ ruEs = getProtoRuleEs thy0+ (st', ruEs') = (`runReader` L.get sigmMaudeHandle sig) $ + partialEvaluation evalStyle ruEs++ replaceProtoRules [] = []+ replaceProtoRules (item:items)+ | isRuleItem item = + [ TextItem ("text", render ppAbsState)+ + ] ++ map RuleItem ruEs' ++ filter (not . isRuleItem) items+ | otherwise = item : replaceProtoRules items++ isRuleItem (RuleItem _) = True+ isRuleItem _ = False++ ppAbsState = + (text $ " the abstract state after partial evaluation" + ++ " contains " ++ show (S.size st') ++ " facts:") $--$+ (numbered' $ map prettyLNFact $ S.toList st') $--$+ (text $ "This abstract state results in " ++ show (length ruEs') ++ + " refined multiset rewriting rules.\n" +++ "Note that the original number of multiset rewriting rules was "+ ++ show (length ruEs) ++ ".\n\n")+ -- Applying provers ------------------- -- | A list of proof methods that could be applied to the given sequent.-applicableProofMethods :: ClosedTheory -> Sequent -> [ProofMethod]-applicableProofMethods thy se = do- m <- possibleProofMethods (L.get pcSignature ctxt) se+applicableProofMethods :: ProofContext -> Sequent -> [ProofMethod]+applicableProofMethods ctxt se = do+ m <- possibleProofMethods ctxt se guard (isJust $ execProofMethod ctxt m se) return m- where- ctxt = getProofContext (L.get sCaseDistKind se) thy -- | Prove both the assertion soundness as well as all lemmas of the theory. If -- the prover fails on a lemma, then its proof remains unchanged.@@ -535,15 +618,15 @@ modify lProof add l where l = ensureFormulaAC l0- kind = lemmaCaseDistKind l- se = formulaToSequent kind preItems $ fromJust $ L.get lFormulaAC l- ctxt = getProofContext kind thy+ ctxt = getProofContext l thy + se = formulaToSequent ctxt preItems $ fromJust $ L.get lFormulaAC l add prf = fromMaybe prf $ runProver prover ctxt se prf -- | Convert a formula modulo AC to a sequent.-formulaToSequent :: CaseDistKind -> [TheoryItem r p] -> FormulaAC -> Sequent-formulaToSequent kind lems = - addLemmasToSequent lems . sequentFromFormula kind+formulaToSequent :: ProofContext -> [TheoryItem r p] -> FormulaAC -> Sequent+formulaToSequent ctxt lems = + addLemmasToSequent lems + . sequentFromFormula (L.get pcCaseDistKind ctxt) (L.get pcTraceQuantifier ctxt) -- | Add the lemmas that have an associated AC variant to this sequent. addLemmasToSequent :: [TheoryItem r p] -> Sequent -> Sequent@@ -567,7 +650,7 @@ set lFormulaAC (Just fmAC) l where -- FIXME: AC-variant of formula is formula itself.- -- This is ensured by well-formed check (not implemented yet).+ -- This must be ensured by well-formed check (not implemented yet). fmAC = fromMaybe (L.get lFormulaE l) $ L.get lFormulaAC l @@ -593,9 +676,8 @@ change preItems (LemmaItem l0) = do let l1 = ensureFormulaAC l0- kind = lemmaCaseDistKind l1- ctxt = getProofContext kind thy- se <- formulaToSequent kind preItems <$> L.get lFormulaAC l1+ ctxt = getProofContext l1 thy+ se <- formulaToSequent ctxt preItems <$> L.get lFormulaAC l1 l2 <- modA lProof (runProver prover ctxt se) l1 return $ LemmaItem l2 change _ _ = error "LemmaProof: change: impossible"@@ -639,14 +721,19 @@ as -> text (L.get lName l) <-> (brackets $ fsep $ punctuate comma $ map prettyLemmaAttribute as) where- prettyLemmaAttribute TypingLemma = text "typing"- prettyLemmaAttribute ReuseLemma = text "reuse"+ prettyLemmaAttribute TypingLemma = text "typing"+ prettyLemmaAttribute ReuseLemma = text "reuse"+ prettyLemmaAttribute InvariantLemma = text "invariant" -- | Pretty print a lemma. prettyLemma :: HighlightDocument d => (p -> d) -> Lemma p -> d prettyLemma ppPrf l = kwLemmaModulo "E" <-> prettyLemmaName l <> colon $-$ - (nest 2 $ doubleQuotes $ prettyFormulaE $ L.get lFormulaE l)+ (nest 2 $ + sep [ prettyTraceQuantifier $ L.get lTraceQuantifier l+ , doubleQuotes $ prettyFormulaE $ L.get lFormulaE l+ ]+ ) $-$ maybe emptyDoc ppFormulaAC (L.get lFormulaAC l) $-$@@ -666,9 +753,13 @@ ppFormulaACGuarded fmAC = case fromFormulaNegate fmAC of Left err -> multiComment_ ["conversion to doubly-guarded formula failed:", err]- Right gf -> multiComment- ( text "guarded formula characterizing all attacks:" $-$+ Right gf -> case toSequentTraceQuantifier $ L.get lTraceQuantifier l of+ ExistsNoTrace -> multiComment+ ( text "guarded formula characterizing all counter-examples:" $-$ doubleQuotes (prettyGuarded gf) )+ ExistsSomeTrace -> multiComment+ ( text "guarded formula characterizing all satisfying traces:" $-$+ doubleQuotes (prettyGuarded (negateGuarded gf)) ) {- ppFormulaACInduction fmAC = case fmInd of@@ -680,15 +771,12 @@ where fmInd = applyInduction =<< fromFormulaNegate fmAC -}-{-+ -- | Pretty-print a non-empty bunch of intruder rules. prettyIntruderVariants :: HighlightDocument d => [IntrRuleAC] -> d-prettyIntruderVariants [] = multiComment $ vsep- [ text "No intruder variants found. You can generate and cache them using the command"- , nest 2 (text "tamarin-prover intruder -O")- ] prettyIntruderVariants vs = vcat . intersperse (text "") $ map prettyIntrRuleAC vs +{- -- | Pretty-print the intruder variants section. prettyIntrVariantsSection :: HighlightDocument d => [IntrRuleAC] -> d prettyIntrVariantsSection rules = @@ -710,12 +798,14 @@ -- | Pretty print an closed rule together with its assertion soundness proof. prettyClosedProtoRule :: HighlightDocument d => ClosedProtoRule -> d prettyClosedProtoRule cru =- (prettyProtoRuleE $ L.get cprRuleE cru) $-$ - (nest 2 $ ppRuleAC $ L.get cprRuleAC cru)+ (prettyProtoRuleE ruE) $--$+ (nest 2 $ prettyLoopBreakers (L.get rInfo ruAC) $-$ ppRuleAC) where- ppRuleAC ru- | isTrivialProtoRuleAC ru = multiComment_ ["has exactly the trivial AC variant"]- | otherwise = multiComment $ prettyProtoRuleAC ru+ ruAC = L.get cprRuleAC cru+ ruE = L.get cprRuleE cru+ ppRuleAC+ | isTrivialProtoVariantAC ruAC ruE = multiComment_ ["has exactly the trivial AC variant"]+ | otherwise = multiComment $ prettyProtoRuleAC ruAC -- | Pretty print an open theory. prettyOpenTheory :: HighlightDocument d => OpenTheory -> d@@ -726,12 +816,18 @@ -- | Pretty print a closed theory. prettyClosedTheory :: HighlightDocument d => ClosedTheory -> d-prettyClosedTheory = +prettyClosedTheory thy = prettyTheory prettySignatureWithMaude (const emptyDoc) -- (prettyIntrVariantsSection . intruderRules . L.get crcRules) prettyClosedProtoRule prettyIncrementalProof+ thy+ -- $--$+ -- (multiComment $ + -- let ruEs = getProtoRuleEs thy+ -- in prettyAbstractState ruEs $ absInterpretation ruEs+ -- ) prettyClosedSummary :: Document d => ClosedTheory -> d prettyClosedSummary thy =@@ -740,17 +836,27 @@ lemmaSummaries = do LemmaItem lem <- L.get thyItems thy let (status, Sum siz) = foldProof proofStepSummary $ L.get lProof lem- return $ text (L.get lName lem) <> colon <-> - text (showProofStatus status) <->+ quantifier = (toSequentTraceQuantifier $ L.get lTraceQuantifier lem)+ analysisType = parens $ prettyTraceQuantifier $ L.get lTraceQuantifier lem+ return $ text (L.get lName lem) <-> analysisType <> colon <-> + text (showProofStatus quantifier status) <-> parens (integer siz <-> text "steps") proofStepSummary = proofStepStatus &&& const (Sum (1::Integer)) ++-- | Pretty print a 'TraceQuantifier'.+prettyTraceQuantifier :: Document d => TraceQuantifier -> d+prettyTraceQuantifier ExistsTrace = text "exists-trace"+prettyTraceQuantifier AllTraces = text "all-traces"++ -- Instances: FIXME: Sort them into the right files -------------------------------------------------- $( derive makeBinary ''TheoryItem) $( derive makeBinary ''LemmaAttribute)+$( derive makeBinary ''TraceQuantifier) $( derive makeBinary ''Lemma) $( derive makeBinary ''ClosedProtoRule) $( derive makeBinary ''ClosedRuleCache)@@ -758,6 +864,7 @@ $( derive makeNFData ''TheoryItem) $( derive makeNFData ''LemmaAttribute)+$( derive makeNFData ''TraceQuantifier) $( derive makeNFData ''Lemma) $( derive makeNFData ''ClosedProtoRule) $( derive makeNFData ''ClosedRuleCache)
+ src/Theory/AbstractInterpretation.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}+-- |+-- Copyright : (c) 2012 Benedikt Schmidt & Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+--+-- Abstract intepretation for partial evaluation of multiset rewriting+-- systems.+module Theory.AbstractInterpretation (+ -- * Combinator to define abstract interpretations+ interpretAbstractly++ -- ** Actual interpretations+ , EvaluationStyle(..)+ , partialEvaluation++ ) where++import Debug.Trace++import Control.Basics+import Control.Monad.Bind+import Control.Monad.Reader++import Data.List+import qualified Data.Set as S+import Data.Traversable (traverse)+import Data.Label++import Text.PrettyPrint.Highlight+import Term.Substitution+import Theory.Rule++------------------------------------------------------------------------------+-- Abstract enough versions of builtin rules for computing+------------------------------------------------------------------------------+++-- | Higher-order combinator to construct abstract interpreters.+interpretAbstractly+ :: (Eq s, HasFrees i, Apply i)+ => ([Equal LNFact] -> [LNSubstVFresh]) + -- ^ Unification of equalities over facts. We assume that facts with+ -- different tags are never unified.+ -> s -- ^ Initial abstract state.+ -> (LNFact -> s -> s) -- ^ Add a fact to the abstract state+ -> (s -> [LNFact]) -- ^ Facts of a state.+ -> [Rule i]+ -- ^ Multiset rewriting rules to apply abstractly.+ -> [(s, [Rule i])]+ -- ^ Sequence of abstract states and refined versions of all given+ -- multiset rewriting rules.+interpretAbstractly unifyFactEqs initState addFact stateFacts rus =+ go st0+ where+ st0 = addFact (freshFact (varTerm (LVar "z" LSortFresh 0))) $+ addFact (inFact (varTerm (LVar "z" LSortMsg 0))) $+ initState++ -- Repeatedly refine all rules and add all their conclusions until the+ -- state doesn't change anymore.+ go st =+ (st, rus') : if st == st' then [] else go st'+ where+ rus' = concatMap refineRule rus+ st' = foldl' (flip addFact) st $ concatMap (get rConcs) rus'++ -- Refine a rule in the context of an abstract state: for all premise+ -- to state facts combinations, try to solve the corresponding+ -- E-unification problem. If successful, return the rule with the+ -- unifier applied.+ refineRule ru = (`evalFreshT` avoid ru) $ do+ eqs <- forM (get rPrems ru) $ \prem -> msum $ do + fa <- stateFacts st+ guard (factTag prem == factTag fa)+ -- we compute a list of 'FreshT []' actions for the outer msum+ return (Equal prem <$> rename fa)+ subst <- msum $ freshToFree <$> unifyFactEqs eqs+ return $ apply subst ru++-- | How to report on performing a partial evaluation.+data EvaluationStyle = Silent | Summary | Tracing++-- | Concrete partial evaluator activated with flag: --partial-evaluation+partialEvaluation :: EvaluationStyle + -> [ProtoRuleE] -> WithMaude (S.Set LNFact, [ProtoRuleE])+partialEvaluation evalStyle ruEs = reader $ \hnd ->+ consumeEvaluation $ interpretAbstractly + ((`runReader` hnd) . unifyLNFactEqs) -- FIXME: Use E-unification here+ S.empty+ (S.insert . absFact)+ S.toList+ ruEs+ where+ consumeEvaluation [] = error "partialEvaluation: impossible"+ consumeEvaluation ((st0, rus0) : rest0) =+ go (0 :: Int) st0 rus0 rest0+ where+ go _ st rus [] = + ( st+ , nubBy eqModuloFreshnessNoAC $ -- remove duplicates+ map ((`evalFresh` nothingUsed) . rename) rus+ )+ go i st _ ((st', rus') : rest) =+ withTrace (go (i + 1) st' rus' rest)+ where+ incDesc = " partial evaluation: step " ++ show i ++ " added " +++ show (S.size st' - S.size st) ++ " facts"+ withTrace = case evalStyle of+ Silent -> id+ Summary -> trace incDesc+ Tracing -> trace $ incDesc ++ "\n\n" +++ ( render $ nest 2 $ numbered' $ map prettyLNFact $+ S.toList $ st' `S.difference` st ) ++ "\n"+ ++ -- NOTE: We should use an abstract state that identifies all variables at+ -- the same position provided they have the same sort.+ absFact :: LNFact -> LNFact+ absFact fa = case fa of + Fact OutFact _ -> outFact (varTerm (LVar "z" LSortMsg 0))+ Fact tag ts -> Fact tag $ evalAbstraction $ traverse absTerm ts+ where+ evalAbstraction = (`evalBind` noBindings) . (`evalFreshT` nothingUsed)++ absTerm t = case viewTerm t of + Lit (Con _) -> pure t+ FApp (sym@(NonAC (_f,_k))) ts + -> fApp sym <$> traverse absTerm ts+ -- | "p" `isPrefixOf` f -> FApp sym <$> traverse absTerm ts+ _ -> importBinding mkVar t (varName t)+ where+ mkVar name idx = varTerm (LVar name (sortOfLNTerm t) idx)+ varName (viewTerm -> Lit (Var v)) = lvarName v+ varName _ = "z"
src/Theory/Atom.hs view
@@ -5,8 +5,11 @@ , DeriveDataTypeable , TupleSections , TemplateHaskell+ , ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ -- spurious warnings for view patterns -- | -- Copyright : (c) 2011, 2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE)@@ -31,8 +34,8 @@ ) where -import Term.Rewriting.NormAC-import Theory.Fact+-- import Term.Rewriting.NormAC+import Theory.Rule import Theory.Pretty import Data.Monoid (mappend)@@ -56,7 +59,7 @@ | Less t t | Last t | DedBefore t t- | EdgeA (t, Int) (t, Int)+ | EdgeA (t, ConcIdx) (t, PremIdx) deriving( Eq, Ord, Show, Data, Typeable ) -- | @LAtom@ are the atoms we actually use in graph formulas input by the user.@@ -122,18 +125,18 @@ apply _ x@(Bound _) = x apply subst x@(Free v) = maybe x extractVar $ imageOf subst v where- extractVar (Lit (Var v')) = Free v'- extractVar t = + extractVar (viewTerm -> Lit (Var v')) = Free v'+ extractVar _t = error $ "apply (BLVar): variable '" ++ show v ++ - "' substituted with term '" ++ show t ++ "'"+ "' substituted with term '" -- ++ show _t ++ "'" instance Apply BLTerm where- apply subst = normAC . (>>= applyBLLit)+ apply subst = (`bindTerm` applyBLLit) where applyBLLit :: Lit Name BLVar -> BLTerm applyBLLit l@(Var (Free v)) = - maybe (Lit l) (fmap (fmap Free)) (imageOf subst v)- applyBLLit l = Lit l+ maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v)+ applyBLLit l = lit l instance Apply BLAtom where apply subst (Action i fact) = Action (apply subst i) (apply subst fact)
src/Theory/Fact.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell, FlexibleContexts, DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-} -- | -- Copyright : (c) 2011, 2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE)@@ -33,6 +34,7 @@ , DirTag(..) , kFactView+ , dedFactView , isKFact , kuFact , kdFact@@ -42,6 +44,7 @@ , outFact , inFact , kLogFact+ , dedLogFact , protoFact -- * NFact@@ -51,6 +54,7 @@ , LFact , LNFact , unifyLNFactEqs+ , unifiableLNFacts , matchLNFact -- * Pretty-Printing@@ -77,7 +81,7 @@ import Term.Unification -import Text.Isar+import Text.PrettyPrint.Class ------------------------------------------------------------------------------@@ -91,10 +95,12 @@ data FactTag = ProtoFact Multiplicity String Int -- ^ A protocol fact together with its arity and multiplicity. | FreshFact -- ^ Freshly generated value.- | OutFact -- ^ Sent by the protocol- | InFact -- ^ Officially known by the intruder/network.+ | OutFact -- ^ Sent by the protocol+ | InFact -- ^ Officially known by the intruder/network. | KUFact -- ^ Up-knowledge fact in messsage deduction. | KDFact -- ^ Down-knowledge fact in message deduction.+ | DedFact -- ^ Log-fact denoting that the intruder deduced + -- a message using a construction rule. deriving( Eq, Ord, Show, Typeable, Data ) -- | Facts.@@ -133,18 +139,18 @@ ------------------ -- | Message fact exponentation tag.-data ExpTag = IsExp | IsNoExp+data ExpTag = CannotExp | CanExp deriving( Eq, Ord, Show) -- | Exponentiation-symbol to term. expTagToTerm :: ExpTag -> LNTerm-expTagToTerm IsExp = Lit (Con (Name PubName (NameId ("exp"))))-expTagToTerm IsNoExp = Lit (Con (Name PubName (NameId ("noexp"))))+expTagToTerm CannotExp = lit (Con (Name PubName (NameId ("noexp"))))+expTagToTerm CanExp = lit (Con (Name PubName (NameId ("exp")))) -- | Term to exponentiation-symbol. termToExpTag :: LNTerm -> Maybe ExpTag-termToExpTag (Lit (Con (Name PubName (NameId ("exp"))))) = return IsExp-termToExpTag (Lit (Con (Name PubName (NameId ("noexp"))))) = return IsNoExp+termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("noexp"))))) = return CannotExp+termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("exp"))))) = return CanExp termToExpTag _ = mzero @@ -169,17 +175,27 @@ kFactView :: LNFact -> Maybe (DirTag, Maybe ExpTag, LNTerm) kFactView fa = case fa of Fact KUFact [e, m] -> Just (UpK, termToExpTag e, m)- Fact KUFact _ -> errMalformed+ Fact KUFact _ -> errMalformed "kFactView" fa Fact KDFact [e, m] -> Just (DnK, termToExpTag e, m)- Fact KDFact _ -> errMalformed+ Fact KDFact _ -> errMalformed "kFactView" fa _ -> Nothing- where- errMalformed = error $ show "viewKFact: malformed fact: " ++ show fa +-- | View a deduction logging fact.+dedFactView :: LNFact -> Maybe LNTerm+dedFactView fa = case fa of+ Fact DedFact [m] -> Just m+ Fact DedFact _ -> errMalformed "dedFactView" fa+ _ -> Nothing+ -- | True if the fact is a message-deduction fact. isKFact :: LNFact -> Bool isKFact = isJust . kFactView +-- | Mark a fact as malformed.+errMalformed :: String -> LNFact -> a+errMalformed caller fa =+ error $ caller ++ show ": malformed fact: " ++ show fa+ -- Constructing facts --------------------- @@ -199,6 +215,11 @@ kLogFact :: t -> Fact t kLogFact = protoFact Linear "K" . return +-- | A fact logging that the intruder deduced a message using a construction+-- rule. We use this to formulate invariants over normal dependency graphs.+dedLogFact :: t -> Fact t+dedLogFact = Fact DedFact . return+ -- | A protocol fact denotes a fact generated by a protocol rule. protoFact :: Multiplicity -> String -> [t] -> Fact t protoFact multi name ts = Fact (ProtoFact multi name (length ts)) ts@@ -234,9 +255,10 @@ ProtoFact _ _ k -> k KUFact -> 2 KDFact -> 2+ DedFact -> 1 FreshFact -> 1- InFact -> 1- OutFact -> 1+ InFact -> 1+ OutFact -> 1 -- | The arity of a 'Fact'. factArity :: Fact t -> Int@@ -274,10 +296,13 @@ -- | Unify a list of @LFact@ equalities. unifyLNFactEqs :: [Equal LNFact] -> WithMaude [LNSubstVFresh] unifyLNFactEqs eqs - -- TODO: Check if the arity of the facts is also checked. | all (evalEqual . fmap factTag) eqs = - unifyLNTerm (map (fmap (listToTerm . factTerms)) eqs)+ unifyLNTerm (map (fmap (fAppList . factTerms)) eqs) | otherwise = return []++-- | 'True' iff the two facts are unifiable.+unifiableLNFacts :: LNFact -> LNFact -> WithMaude Bool+unifiableLNFacts fa1 fa2 = (not . null) <$> unifyLNFactEqs [Equal fa1 fa2] -- | @matchLFact t p@ is a complete set of AC matchers for the term fact @t@ -- and the pattern fact @p@.@@ -299,6 +324,7 @@ showFactTag tag = case tag of KUFact -> "!KU" KDFact -> "!KD"+ DedFact -> "Ded" InFact -> "In" OutFact -> "Out" FreshFact -> "Fr"
src/Theory/Formula.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, BangPatterns, StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, BangPatterns #-} {-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ -- spurious warnings for view patterns -- | -- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt -- License : GPL v3 (see LICENSE)@@ -109,7 +112,7 @@ -- | Fold a formula. {-# INLINE foldFormulaScope #-}-foldFormulaScope :: (Int -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b)+foldFormulaScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b) -> (b -> b) -> (Connective -> b -> b -> b) -> (Quantifier -> s -> b -> b) -> Formula s c v@@ -127,19 +130,26 @@ -- Instances ------------ -+{- instance Functor (Formula s c) where fmap f = foldFormula (Ato . fmap (fmap (fmap (fmap f)))) TF Not Conn Qua+-} instance Foldable (Formula s c) where foldMap f = foldFormula (foldMap (foldMap (foldMap (foldMap f)))) mempty id (const mappend) (const $ const id) +traverseFormula :: (Ord v, Ord c, Ord v', Applicative f)+ => (v -> f v') -> Formula s c v -> f (Formula s c v')+traverseFormula f = foldFormula (liftA Ato . traverse (traverseTerm (traverse (traverse f))))+ (pure . TF) (liftA Not)+ (liftA2 . Conn) ((liftA .) . Qua)+{- instance Traversable (Formula a s) where- traverse f = foldFormula (liftA Ato . traverse (traverse (traverse (traverse f))))+ traverse f = foldFormula (liftA Ato . traverseAtom (traverseTerm (traverseLit (traverseBVar f)))) (pure . TF) (liftA Not) (liftA2 . Conn) ((liftA .) . Qua)-+-} -- Abbreviations ----------------@@ -174,19 +184,19 @@ type LNFormula = Formula (String, LSort) Name LVar -- | Change the representation of atoms.-mapAtoms :: (Int -> Atom (VTerm c (BVar v))+mapAtoms :: (Integer -> Atom (VTerm c (BVar v)) -> Atom (VTerm c1 (BVar v1))) -> Formula s c v -> Formula s c1 v1 mapAtoms f = foldFormulaScope (\i a -> Ato $ f i a) TF Not Conn Qua -- | @openFormula f@ returns @Just (v,Q,f')@ if @f = Q v. f'@ modulo -- alpha renaming and @Nothing otherwise@. @v@ is always chosen to be fresh.-openFormula :: (MonadFresh m)+openFormula :: (MonadFresh m, Ord c) => LFormula c -> Maybe (Quantifier, m (LVar, LFormula c)) openFormula (Qua qua (n,s) fm) = Just ( qua , do x <- freshLVar n s- return $ (x, mapAtoms (\i a -> fmap (fmap (subst x i)) a) fm)+ return $ (x, mapAtoms (\i a -> fmap (mapLits (subst x i)) a) fm) ) where subst x i (Var (Bound i')) | i == i' = Var $ Free x@@ -194,11 +204,14 @@ openFormula _ = Nothing +mapLits :: (Ord a, Ord b) => (a -> b) -> Term a -> Term b+mapLits f (viewTerm -> Lit l) = lit . f $ l+mapLits f (viewTerm -> FApp o as) = fApp o (map (mapLits f) as) -- | @openFormulaPrefix f@ returns @Just (vs,Q,f')@ if @f = Q v_1 .. v_k. f'@ -- modulo alpha renaming and @Nothing otherwise@. @vs@ is always chosen to be -- fresh.-openFormulaPrefix :: (MonadFresh m)+openFormulaPrefix :: (MonadFresh m, Ord c) => LFormula c -> m ([LVar], Quantifier, LFormula c) openFormulaPrefix f0 = case openFormula f0 of Nothing -> error $ "openFormulaPrefix: no outermost quantifier"@@ -222,7 +235,7 @@ instance HasFrees LNFormula where foldFrees f = foldMap (foldFrees f)- mapFrees f = traverse (mapFrees f)+ mapFrees f = traverseFormula (mapFrees f) instance Apply LNFormula where apply subst = mapAtoms (const $ apply subst)@@ -235,19 +248,19 @@ type FormulaAC = LFormula Name -- | Introduce a bound variable for a free variable.-quantify :: Eq v => v -> Formula s c v -> Formula s c v+quantify :: (Ord c, Ord v, Eq v) => v -> Formula s c v -> Formula s c v quantify x =- mapAtoms (\i a -> fmap (fmap (fmap (>>= (subst i)))) a)+ mapAtoms (\i a -> fmap (mapLits (fmap (>>= subst i))) a) where subst i v | v == x = Bound i | otherwise = Free v -- | Create a universal quantification with a sort hint for the bound variable.-forall :: Eq v => s -> v -> Formula s c v -> Formula s c v+forall :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v forall hint x = Qua All hint . quantify x -- | Create a existential quantification with a sort hint for the bound variable.-exists :: Eq v => s -> v -> Formula s c v -> Formula s c v+exists :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v exists hint x = Qua Ex hint . quantify x ------------------------------------------------------------------------------@@ -255,7 +268,7 @@ ------------------------------------------------------------------------------ -- | Pretty print a formula.-prettyLFormula :: (HighlightDocument d, MonadFresh m) +prettyLFormula :: (HighlightDocument d, MonadFresh m, Ord c) => (Atom (VTerm c LVar) -> d) -- ^ Function for pretty printing atoms -> LFormula c -- ^ Formula to pretty print. -> m d -- ^ Pretty printed formula.@@ -265,7 +278,7 @@ extractFree (Free v) = v extractFree (Bound i) = error $ "prettyFormula: illegal bound variable '" ++ show i ++ "'" - pp (Ato a) = return $ ppAtom (fmap (fmap (fmap extractFree)) a)+ pp (Ato a) = return $ ppAtom (fmap (mapLits (fmap extractFree)) a) pp (TF True) = return $ operator_ "T" -- "⊤" pp (TF False) = return $ operator_ "F" -- "⊥"
src/Theory/IntruderRules.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ -- spurious warnings for view patterns -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt -- License : GPL v3 (see LICENSE)@@ -13,20 +15,25 @@ -- , xorIntruderRules -- there are no multiset intruder rules ) where -import Theory.Rule+import Control.Monad.Fresh+import Control.Basics+import Control.Monad.Reader++import qualified Data.Set as S+import Data.List+import qualified Data.ByteString.Char8 as BC++import Extension.Data.Label++import Utils.Misc+ import Term.SubtermRule import Term.Positions+import Term.Maude.Signature import Term.Rewriting.Norm import Term.Narrowing.Variants.Compute -import Utils.Misc--import Control.Monad.Fresh-import Data.List-import Control.Basics-import Extension.Data.Label--import Control.Monad.Reader+import Theory.Rule @@ -59,19 +66,23 @@ [ Rule CoerceRule [Fact KDFact [f_var, x_var]] [Fact KUFact [f_var,x_var]]- []- , Rule (IntrApp "pub")+ [dedLogFact x_var]+ , Rule PubConstrRule [] [Fact KUFact [f_var,x_pub_var]]- [] - , Rule (IntrApp "fresh")+ [dedLogFact x_pub_var] + , Rule FreshConstrRule [Fact FreshFact [x_fresh_var]] [Fact KUFact [f_var,x_fresh_var]]- []- , Rule (IntrApp "isend")+ [dedLogFact x_fresh_var]+ , Rule ISendRule [Fact KUFact [f_var, x_var]] [Fact InFact [x_var]]- [protoFact Linear "K" [x_var]]+ [kLogFact x_var]+ , Rule IRecvRule+ [Fact OutFact [x_var]]+ [Fact KDFact [expTagToTerm CanExp, x_var]]+ [] ] where f_var = varTerm (LVar "f_" LSortMsg 0)@@ -84,14 +95,14 @@ ------------------------------------------------------------------------------ destructionRules :: StRule -> [IntrRuleAC]-destructionRules (StRule lhs@(FApp (NonAC (f,_)) _) (RhsPosition pos)) =+destructionRules (StRule lhs@(viewTerm -> FApp (NonAC (f,_)) _) (RhsPosition pos)) = go [] lhs pos where- rhs = lhs >* pos- go _ _ [] = []+ rhs = lhs `atPos` pos+ go _ _ [] = [] -- term already in premises- go _ (FApp _ _) (_:[]) = []- go uprems (FApp _ as) (i:p) =+ go _ (viewTerm -> FApp _ _) (_:[]) = []+ go uprems (viewTerm -> FApp _ as) (i:p) = irule ++ go uprems' t' p where uprems' = uprems++[ t | (j, t) <- zip [0..] as, i /= j ]@@ -101,9 +112,9 @@ dfact <- kdFact Nothing t' ufacts <- mapM (kuFact Nothing) uprems' concfact <- kdFact Nothing rhs- return [ Rule (IntrApp f) (dfact:ufacts) [concfact] [] ]+ return [ Rule (DestrRule (BC.unpack f)) (dfact:ufacts) [concfact] [] ] else []- go _ (Lit _) (_:_) =+ go _ (viewTerm -> Lit _) (_:_) = error "IntruderRules.destructionRules: impossible, position invalid" destructionRules _ = []@@ -127,18 +138,19 @@ -- the free (not Xor, DH, and MSet) part of the given signature. subtermIntruderRules :: MaudeSig -> [IntrRuleAC] subtermIntruderRules maudeSig =- minimizeIntruderRules $ concatMap destructionRules (stRules maudeSig)- ++ constructionRules (funSig maudeSig)+ minimizeIntruderRules $ concatMap destructionRules (S.toList $ stRules maudeSig)+ ++ constructionRules (functionSymbols maudeSig) constructionRules :: FunSig -> [IntrRuleAC] constructionRules fSig =- [ createRule s k | (s,k) <- fSig ]+ [ createRule s k | (s,k) <- S.toList fSig ] where createRule s k = (`evalFresh` nothingUsed) $ do vars <- map varTerm <$> (sequence $ replicate k (freshLVar "x" LSortMsg)) pfacts <- mapM (kuFact Nothing) vars- concfact <- kuFact (Just IsNoExp) (FApp (NonAC (s,k)) vars)- return $ Rule (IntrApp s) pfacts [concfact] []+ let m = fApp (NonAC (s,k)) vars+ concfact <- kuFact (Just CanExp) m+ return $ Rule (ConstrRule (BC.unpack s)) pfacts [concfact] [dedLogFact m] dropExpTag :: Fact a -> Fact a dropExpTag (Fact KUFact [_e,m]) = Fact KUFact [m]@@ -151,45 +163,51 @@ dhIntruderRules :: WithMaude [IntrRuleAC] dhIntruderRules = reader $ \hnd -> minimizeIntruderRules $- [expRule True, invRule True]- ++ concatMap (variants hnd) [expRule False, invRule False]+ [ expRule ConstrRule kuFact (return . dedLogFact) + , invRule ConstrRule kuFact (return . dedLogFact)+ ] ++ + concatMap (variantsIntruder hnd) + [ expRule DestrRule kdFact (const [])+ , invRule DestrRule kdFact (const [])+ ] where- expRule isConstr = (`evalFresh` nothingUsed) $ do+ expRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do b <- varTerm <$> freshLVar "x" LSortMsg e <- varTerm <$> freshLVar "x" LSortMsg- bfact <- fact isConstr (Just IsNoExp) b+ bfact <- kudFact (Just CanExp) b efact <- kuFact Nothing e- concfact <- fact isConstr (Just IsExp) (FApp (NonAC ("exp",2)) [b, e])- return $ Rule (IntrApp "exp") [bfact, efact] [concfact] []+ let conc = fAppExp (b, e)+ concfact <- kudFact (Just CannotExp) conc+ return $ Rule (mkInfo "exp") [bfact, efact] [concfact] (mkAction conc) - invRule isConstr = (`evalFresh` nothingUsed) $ do+ invRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do x <- varTerm <$> freshLVar "x" LSortMsg- bfact <- fact isConstr Nothing x- concfact <- fact isConstr (Just IsNoExp) (FApp (NonAC invSym) [x])- return $ Rule (IntrApp "inv") [bfact] [concfact] []+ bfact <- kudFact Nothing x+ let conc = fAppInv x+ concfact <- kudFact (Just CanExp) conc+ return $ Rule (mkInfo "inv") [bfact] [concfact] (mkAction conc) - fact True = kuFact- fact False = kdFact - variants hnd ru = do- let concTerms = concatMap factTerms- (get rPrems ru++get rConcs ru++get rActs ru)- fsigma <- computeVariants (listToTerm concTerms) `runReader` hnd- let sigma = freshToFree fsigma `evalFreshAvoiding` concTerms- ruvariant = normRule' (apply sigma ru) `runReader` hnd- guard (frees (get rConcs ruvariant) /= [] &&- -- ground terms are already deducible by applying construction rules- ruvariant /= ru &&- -- this is a construction rule- (map dropExpTag (get rConcs ruvariant))- \\ (map dropExpTag (get rPrems ruvariant)) /= []- -- The conclusion is included in the premises- )+variantsIntruder :: MaudeHandle -> IntrRuleAC -> [IntrRuleAC]+variantsIntruder hnd ru = do+ let concTerms = concatMap factTerms+ (get rPrems ru++get rConcs ru++get rActs ru)+ fsigma <- computeVariants (fAppList concTerms) `runReader` hnd+ let sigma = freshToFree fsigma `evalFreshAvoiding` concTerms+ ruvariant = normRule' (apply sigma ru) `runReader` hnd+ guard (frees (get rConcs ruvariant) /= [] &&+ -- ground terms are already deducible by applying construction rules+ ruvariant /= ru &&+ -- this is a construction rule+ (map dropExpTag (get rConcs ruvariant))+ \\ (map dropExpTag (get rPrems ruvariant)) /= []+ -- The conclusion is included in the premises+ ) - case concatMap factTerms $ get rConcs ruvariant of- [_, FApp (AC Mult) _] ->- fail "Rules with product conclusion are redundant"- _ -> return ruvariant+ case concatMap factTerms $ get rConcs ruvariant of+ [_, viewTerm -> FApp (AC Mult) _] ->+ fail "Rules with product conclusion are redundant"+ _ -> return ruvariant normRule' :: IntrRuleAC -> WithMaude IntrRuleAC
src/Theory/Parser.hs view
@@ -12,6 +12,7 @@ , parseOpenTheoryString , parseProofMethod , parseLemma+ , parseIntruderRulesDH ) where import Prelude hiding (id, (.))@@ -22,14 +23,12 @@ import qualified Data.Set as S import qualified Data.Map as M import Data.Monoid-import Data.Maybe+import qualified Data.ByteString.Char8 as BC import Control.Monad import Control.Applicative hiding (empty, many, optional) import Control.Category -import Extension.Prelude- import Text.Parsec.Pos import Text.Parsec hiding (token, (<|>), string ) import qualified Text.Parsec as P@@ -39,8 +38,9 @@ , alexGetPos, alexMonadScan ) import Term.SubtermRule+import Term.Substitution -import Text.Isar (render)+import Text.PrettyPrint.Class (render) import Theory @@ -113,12 +113,16 @@ -- | Parse an identifier as a string identifier :: Parser String identifier = token extract- where extract (IDENT name) = Just $ name- extract _ = Nothing+ where extract (IDENT name) + -- don't allow certain reserved words as identifiers+ | not (name `elem` ["in","let","rule"]) = Just name+ extract _ = Nothing --- | Parse a fixed string which could be an identifier.+-- | Parse an identifier as a string string :: String -> Parser ()-string cs = (try $ do { i <- identifier; guard (i == cs) }) <?> ('`' : cs ++ "'")+string cs = token extract+ where extract (IDENT name) | cs == name = Just ()+ extract _ = Nothing -- | Parse a sequence of fixed strings. strings :: [String] -> Parser ()@@ -176,6 +180,10 @@ -> FilePath -> IO OpenTheory parseOpenTheory flags = parseFile (theory flags) +-- | Parse DH intruder rules.+parseIntruderRulesDH :: FilePath -> IO [IntrRuleAC]+parseIntruderRulesDH = parseFile (setState dhMaudeSig >> many intrRule)+ -- | Parse a security protocol theory file. -- TODO: This function seems to parse a string, not a file from a file path? parseProofMethod :: FilePath -> Either ParseError ProofMethod@@ -245,10 +253,10 @@ ------------------------------------------------------------------------------ -- | Parse an identifier possibly indexed with a number.-indexedIdentifier :: Parser (String, Int)-indexedIdentifier =- -- FIXME: It might be confusing that 'x.0' and 'x' denote the same variable- (\s mi -> (s, fromMaybe 0 mi)) <$> identifier <*> optionMaybe (try (kw DOT *> integer))+indexedIdentifier :: Parser (String, Integer)+indexedIdentifier = do+ (,) <$> identifier+ <*> option 0 (try (kw DOT *> (fromIntegral <$> integer))) -- | Parse a logical variable with the given sorts allowed. sortedLVar :: [LSort] -> Parser LVar@@ -299,79 +307,80 @@ lookupNonACArity :: String -> Parser Int lookupNonACArity op = do maudeSig <- getState- case lookup op (funSigForMaudeSig maudeSig) of+ case lookup (BC.pack op) (S.toList $ allFunctionSymbols maudeSig) of Nothing -> fail $ "unknown operator `" ++ op ++ "'" Just k -> return k -- | Parse an n-ary operator application for arbitrary n.-naryOpApp :: Parser (Term l) -> Parser (Term l)-naryOpApp lit = do+naryOpApp :: Ord l => Parser (Term l) -> Parser (Term l)+naryOpApp plit = do op <- identifier k <- lookupNonACArity op ts <- parens $ if k == 1- then return <$> tupleterm lit- else sepBy (multterm lit) (kw COMMA)+ then return <$> tupleterm plit+ else sepBy (multterm plit) (kw COMMA) let k' = length ts when (k /= k') $ fail $ "operator `" ++ op ++"' has arity " ++ show k ++ ", but here it is used with arity " ++ show k'- return $ FApp (NonAC (op, k')) ts+ return $ fAppNonAC (BC.pack op, k') ts -- | Parse a binary operator written as @op{arg1}arg2@.-binaryAlgApp :: Parser (Term l) -> Parser (Term l)-binaryAlgApp lit = do+binaryAlgApp :: Ord l => Parser (Term l) -> Parser (Term l)+binaryAlgApp plit = do op <- identifier k <- lookupNonACArity op- arg1 <- kw LBRACE *> tupleterm lit <* kw RBRACE- arg2 <- term lit+ arg1 <- kw LBRACE *> tupleterm plit <* kw RBRACE+ arg2 <- term plit when (k /= 2) $ fail $ "only operators of arity 2 can be written using the `op{t1}t2' notation"- return $ FApp (NonAC (op, 2)) [arg1, arg2]+ return $ fAppNonAC (BC.pack op, 2) [arg1, arg2] -- | Parse a term.-term :: Parser (Term l) -> Parser (Term l)-term lit = asum+term :: Ord l => Parser (Term l) -> Parser (Term l)+term plit = asum [ pairing <?> "pairs"- , parens (multterm lit)- , kw UNDERSCORE *> (FApp (NonAC invSym) . return <$> term lit)- , string "1" *> pure (FApp (NonAC oneSym) [])+ , parens (multterm plit)+ , string "1" *> pure fAppOne , application <?> "function application" , nullaryApp- , lit + , plit ] <?> "term" where- application = asum $ map (try . ($ lit)) [naryOpApp, binaryAlgApp]- pairing = kw LESS *> tupleterm lit <* kw GREATER+ application = asum $ map (try . ($ plit)) [naryOpApp, binaryAlgApp]+ pairing = kw LESS *> tupleterm plit <* kw GREATER nullaryApp = do maudeSig <- getState- asum [ try (string sym) *> pure (FApp (NonAC (sym,0)) [])- | (sym,0) <- funSigForMaudeSig maudeSig ]+ asum [ try (string (BC.unpack sym)) *> pure (fApp (NonAC (sym,0)) [])+ | (sym,0) <- S.toList $ allFunctionSymbols maudeSig ] -- | A left-associative sequence of exponentations.-expterm :: Parser (Term l) -> Parser (Term l)-expterm lit = chainl1 (term lit) ((\a b -> FApp (NonAC expSym) [a,b]) <$ kw HAT)+expterm :: Ord l => Parser (Term l) -> Parser (Term l)+expterm plit = chainl1 (term plit) ((\a b -> fAppExp (a,b)) <$ kw HAT) -- | A left-associative sequence of multiplications.-multterm :: Parser (Term l) -> Parser (Term l)-multterm lit = chainl1 (expterm lit) ((\a b -> FApp (AC Mult) [a,b]) <$ kw STAR)- -- FIXME: parse as n-ary multiplication+multterm :: Ord l => Parser (Term l) -> Parser (Term l)+multterm plit = do+ dh <- enableDH <$> getState+ if dh -- if DH is not enabled, do not accept 'multterm's and 'expterm's+ then chainl1 (expterm plit) ((\a b -> fAppMult [a,b]) <$ kw STAR)+ else term plit -- | A right-associative sequence of tuples.-tupleterm :: Parser (Term l) -> Parser (Term l)-tupleterm lit = chainr1 pterm ((\a b -> FApp (NonAC pairSym) [a,b])<$ kw COMMA)- where pterm = ifM (enableDH <$> getState) (multterm lit) (term lit)+tupleterm :: Ord l => Parser (Term l) -> Parser (Term l)+tupleterm plit = chainr1 (multterm plit) ((\a b -> fAppPair (a,b))<$ kw COMMA) -- | Parse a fact.-fact :: Parser (Term l) -> Parser (Fact (Term l))-fact lit = +fact :: Ord l => Parser (Term l) -> Parser (Fact (Term l))+fact plit = do multi <- option Linear (kw BANG *> pure Persistent) i <- identifier case i of [] -> fail "empty identifier" (c:_) | isUpper c -> return () | otherwise -> fail "facts must start with upper-case letters"- ts <- parens (sepBy (multterm lit) (kw COMMA))+ ts <- parens (sepBy (multterm plit) (kw COMMA)) mkProtoFact multi i ts <?> "protocol fact" where@@ -384,6 +393,7 @@ "IN" -> singleTerm f inFact "KU" -> return . Fact KUFact "KD" -> return . Fact KDFact+ "DED" -> return . Fact DedFact "FR" -> singleTerm f freshFact _ -> return . protoFact multi f @@ -421,9 +431,18 @@ protoRule :: Parser (ProtoRuleE) protoRule = do name <- try (string "rule" *> optional moduloE *> identifier <* kw COLON) + subst <- option emptySubst letBlock (ps,as,cs) <- genericRule- return $ Rule (StandRule name) ps cs as+ return $ apply subst $ Rule (StandRule name) ps cs as +-- | Parse a let block with bottom-up application semantics.+letBlock :: Parser LNSubst+letBlock = do+ toSubst <$> (string "let" *> many1 definition <* string "in")+ where+ toSubst = foldr1 compose . map (substFromList . return)+ definition = (,) <$> (sortedLVar [LSortMsg] <* kw EQUAL) <*> multterm llit+ -- | Parse an intruder rule. intrRule :: Parser IntrRuleAC intrRule = do@@ -433,9 +452,10 @@ where intrInfo = do name <- identifier- if map toUpper name == "COERCE"- then return $ CoerceRule- else return $ IntrApp name+ case name of+ 'c':cname -> return $ ConstrRule cname+ 'd':dname -> return $ DestrRule dname+ _ -> fail $ "invalid intruder rule name '" ++ name ++ "'" genericRule :: Parser ([LNFact], [LNFact], [LNFact]) genericRule = @@ -627,18 +647,20 @@ -- | Parse an atom with possibly bound logical variables. blatom :: Parser BLAtom-blatom = (fmap (fmap (fmap Free))) <$> asum+blatom = (fmap (fmapTerm (fmap Free))) <$> asum [ flip Action <$> try (fact llit <* actionOp) <*> nodevarTerm <?> "action" , Less <$> try (nodevarTerm <* lessOp) <*> nodevarTerm <?> "less" , DedBefore <$> try (term llit <* dedBeforeOp) <*> nodevarTerm <?> "deduced before"- , EdgeA <$> try (nodePrem <* edgeOp) <*> nodeConc <?> "edge"+ , EdgeA <$> try (nodeConc <* edgeOp) <*> nodePrem <?> "edge" , EqE <$> try (multterm llit <* equalOp) <*> multterm llit <?> "term equality" , EqE <$> (nodevarTerm <* equalOp) <*> nodevarTerm <?> "node equality" ] where - nodevarTerm = (Lit . Var) <$> nodevar- nodePrem = parens ((,) <$> (nodevarTerm <* kw COMMA) <*> integer)- nodeConc = nodePrem+ nodevarTerm = (lit . Var) <$> nodevar+ nodePrem = annNode PremIdx+ nodeConc = annNode ConcIdx+ annNode mkAnn = parens ((,) <$> (nodevarTerm <* kw COMMA) + <*> (mkAnn <$> integer)) -- | Parse an atom of a formula. fatom :: Parser (LFormula Name)@@ -679,7 +701,7 @@ imp = do lhs <- disjuncts asum [ try (kw EQUAL *> kw EQUAL *> kw GREATER) *> - ((lhs .==>.) <$> disjuncts)+ ((lhs .==>.) <$> imp) , pure lhs ] -- | An logical equivalence.@@ -690,18 +712,27 @@ ((lhs .<=>.) <$> imp) , pure lhs ] --- | Parse a lemma attribute.+-- | Parse a 'LemmaAttribute'. lemmaAttribute :: Parser LemmaAttribute lemmaAttribute = asum- [ string "typing" *> pure TypingLemma- , string "reuse" *> pure ReuseLemma+ [ string "typing" *> pure TypingLemma+ , string "reuse" *> pure ReuseLemma+ , string "invariant" *> pure InvariantLemma ] +-- | Parse a 'TraceQuantifier'.+traceQuantifier :: Parser TraceQuantifier+traceQuantifier = asum+ [ string "all" *> kw MINUS *> string "traces" *> pure AllTraces+ , string "exists" *> kw MINUS *> string "trace" *> pure ExistsTrace+ ]+ -- | Parse a lemma. lemma :: Parser (Lemma ProofSkeleton) lemma = skeletonLemma <$> (string "lemma" *> optional moduloE *> identifier) <*> (option [] $ list lemmaAttribute)- <*> (kw COLON *> doubleQuoted iff)+ <*> (kw COLON *> option AllTraces traceQuantifier)+ <*> doubleQuoted iff <*> (proofSkeleton <|> pure (unproven ())) @@ -717,9 +748,9 @@ factSymbol = ProtoFact Linear <$> identifier <*> (kw SLASH *> integer) -builtin :: Parser ()-builtin =- string "builtin" *> kw COLON *> sepBy1 builtinTheory (kw COMMA) *> pure ()+builtins :: Parser ()+builtins =+ string "builtins" *> kw COLON *> sepBy1 builtinTheory (kw COMMA) *> pure () where extendSig msig = modifyState (`mappend` msig) builtinTheory = asum@@ -740,14 +771,14 @@ string "functions" *> kw COLON *> sepBy1 functionSymbol (kw COMMA) *> pure () where functionSymbol = do- funsym <- (,) <$> identifier <*> (kw SLASH *> integer)+ funsym <- (,) <$> (BC.pack <$> identifier) <*> (kw SLASH *> integer) sig <- getState- case lookup (fst funsym) (funSig sig) of+ case lookup (fst funsym) (S.toList $ allFunctionSymbols sig) of Just k | k /= snd funsym -> fail $ "conflicting arities " ++ show k ++ " and " ++ show (snd funsym) ++ - " for `" ++ fst funsym- _ -> setState (sig `mappend` emptyMaudeSig {funSig = [funsym]})+ " for `" ++ BC.unpack (fst funsym)+ _ -> setState (addFunctionSymbol funsym sig) equations :: Parser () equations =@@ -757,7 +788,7 @@ rrule <- RRule <$> term llit <*> (kw EQUAL *> term llit) case rRuleToStRule rrule of Just str ->- modifyState (`mappend` emptyMaudeSig {stRules = [str]})+ modifyState (addStRule str) Nothing -> fail $ "Not a subterm rule: " ++ show rrule @@ -781,7 +812,7 @@ [ do fresh <- globallyFresh addItems flags $ modify (sigpUniqueInsts . thySignature) (S.union fresh) thy- , do builtin+ , do builtins msig <- getState addItems flags $ set (sigpMaudeSig . thySignature) msig thy , do functions
src/Theory/Proof.hs view
@@ -25,8 +25,10 @@ , insertPaths -- ** Folding/modifying proofs+ , mapProofInfo , foldProof- , ProofStatus+ , annotateProof+ , ProofStatus(..) , proofStepStatus , cutOnAttackDFS@@ -58,6 +60,7 @@ , contradictionAndClauseProver -- ** Pretty Printing+ , simplifyVariableIndices , prettyProofMethod , prettyProof , prettyProofWith@@ -90,11 +93,11 @@ import Control.Basics import qualified Control.Monad.State as S+import Control.Monad.Bind+import qualified Control.Monad.Trans.PreciseFresh as Precise import Control.Parallel.Strategies import Control.DeepSeq -import Text.Isar- import Theory.Pretty import Theory.Proof.CaseDistinctions @@ -263,6 +266,9 @@ instance Traversable ProofStep where traverse f (ProofStep m i) = ProofStep m <$> f i +instance HasFrees a => HasFrees (ProofStep a) where+ foldFrees f (ProofStep m i) = foldFrees f m `mappend` foldFrees f i+ mapFrees f (ProofStep m i) = ProofStep <$> mapFrees f m <*> mapFrees f i ------------------------------------------------------------------------------ -- Proof Trees@@ -344,6 +350,16 @@ where go (LNode step cs) = f step `mappend` foldMap go (M.elems cs) +-- | Annotate a proof in a bottom-up fashion.+annotateProof :: (ProofStep a -> [b] -> b) -> Proof a -> Proof b+annotateProof f =+ go+ where+ go (LNode step@(ProofStep method _) cs) =+ LNode (ProofStep method info') cs'+ where+ cs' = M.map go cs+ info' = f step (map (psInfo . root . snd) (M.toList cs')) -- Proof cutting ----------------@@ -352,20 +368,20 @@ data ProofStatus = CompleteProof -- ^ The proof is complete: no sorry, no attack | IncompleteProof -- ^ There is a sorry, but no attack.- | AttackFound -- ^ There is an attack+ | TraceFound -- ^ There is an attack instance Monoid ProofStatus where mempty = CompleteProof - mappend AttackFound _ = AttackFound- mappend _ AttackFound = AttackFound+ mappend TraceFound _ = TraceFound+ mappend _ TraceFound = TraceFound mappend IncompleteProof _ = IncompleteProof mappend _ IncompleteProof = IncompleteProof mappend CompleteProof CompleteProof = CompleteProof -- | The status of a 'ProofStep'. proofStepStatus :: ProofStep a -> ProofStatus-proofStepStatus (ProofStep Attack _) = AttackFound+proofStepStatus (ProofStep Attack _) = TraceFound proofStepStatus (ProofStep (Sorry _) _) = IncompleteProof proofStepStatus (ProofStep _ _) = CompleteProof @@ -404,17 +420,17 @@ case S.runState (checkLevel l prf) CompleteProof of (_, CompleteProof) -> prf (_, IncompleteProof) -> go (l+1) prf- (prf', AttackFound) -> + (prf', TraceFound) -> trace ("attack found at depth: " ++ show l) prf' checkLevel 0 (LNode step@(ProofStep Attack _) _) = - S.put AttackFound >> return (LNode step M.empty)+ S.put TraceFound >> return (LNode step M.empty) checkLevel 0 prf@(LNode (ProofStep _ x) cs) | M.null cs = return prf | otherwise = do st <- S.get msg <- case st of- AttackFound -> return $ "ignored (attack exists)"+ TraceFound -> return $ "ignored (attack exists)" _ -> S.put IncompleteProof >> return "bound reached" return $ LNode (ProofStep (Sorry msg) x) M.empty checkLevel l (LNode step cs) =@@ -454,8 +470,9 @@ [se'] | check se se' -> return $ M.singleton "" se' | otherwise -> mzero ses -> - error $ "execMethod: unexpected number of sequents: " ++ show (length ses) ++- render (nest 2 $ vcat $ map ((text "" $-$) . prettySequent) ses)+ return $ M.fromList (zip (map show [(1::Int)..]) ses)+-- error $ "execMethod: unexpected number of sequents: " ++ show (length ses) +++-- render (nest 2 $ vcat $ map ((text "" $-$) . prettySequent) ses) -- solve the given goal -- PRE: Goal must be valid in this sequent.@@ -499,14 +516,13 @@ emptySequent (L.get sCaseDistKind se) -- | A list of possibly applicable proof methods.-possibleProofMethods :: SignatureWithMaude -> Sequent -> [ProofMethod]-possibleProofMethods sig se =- ((Contradiction . Just) <$> contradictions sig se)- -- For now (12/01/22), we add induction after simplification to ensure- -- that the autoprover doesn't use induction. (Induction can only be- -- executed in a sequent that contains exactly one formula eligible for- -- induction.)- <|> [Simplify, Induction]+possibleProofMethods :: ProofContext -> Sequent -> [ProofMethod]+possibleProofMethods ctxt se =+ ((Contradiction . Just) <$> contradictions (L.get pcSignature ctxt) se)+ <|> (case L.get pcUseInduction ctxt of+ AvoidInduction -> [Simplify, Induction]+ UseInduction -> [Induction, Simplify]+ ) <|> (SolveGoal <$> openGoals se) -- | @proveSequentDFS rules se@ tries to construct a proof that @se@ is valid@@ -522,7 +538,7 @@ where (method, cases) = headDef (Attack, M.empty) $ do- m <- possibleProofMethods (L.get pcSignature ctxt) se + m <- possibleProofMethods ctxt se (m,) <$> maybe mzero return (execProofMethod ctxt m se) @@ -560,8 +576,11 @@ -> Proof (Maybe a, Maybe Sequent) checkProof ctxt prover se (LNode (ProofStep method info) cs) = fromMaybe (node method (M.map noSequentPrf cs)) $ headMay $ do- method' <- method : possibleProofMethods (L.get pcSignature ctxt) se- guard (method `eqModuloFreshness` method')+ method' <- method : possibleProofMethods ctxt se+ -- FIXME: eqModuloFreshness is too strict currently as it doesn't+ -- rename variables to a canonical representative. Moreover, it screws+ -- up if there are AC symbols involved.+ guard (method `eqModuloFreshnessNoAC` method') cases <- maybe mzero return $ execProofMethod ctxt method' se return $ node method' $ checkChildren cases @@ -578,6 +597,7 @@ unhandledCase = mapProofInfo ((,) Nothing) . prover + ------------------------------------------------------------------------------ -- Provers: the interface to the outside world. ------------------------------------------------------------------------------@@ -606,7 +626,7 @@ -- | Map the proof generated by the prover. mapProverProof :: (IncrementalProof -> IncrementalProof) -> Prover -> Prover-mapProverProof f p = Prover $ \ rules se prf -> f<$> runProver p rules se prf+mapProverProof f p = Prover $ \ rules se prf -> f <$> runProver p rules se prf -- | Prover that always fails. failProver :: Prover @@ -693,6 +713,19 @@ -- Pretty printing ------------------------------------------------------------------------------ +-- | Consistently simplify variable indices in the proof; i.e., rename all+-- free variables in a top-down fashion using the 'Precise.FreshT'+-- transformer.+simplifyVariableIndices :: HasFrees a => Proof a -> Proof a+simplifyVariableIndices =+ go noBindings Precise.nothingUsed+ where+ go bindSt freshSt (LNode step cs) =+ case Precise.runFresh (runBindT (someInst step) bindSt) freshSt of+ ((step', bindSt'), freshSt') ->+ LNode step' (M.map (go bindSt' freshSt') cs)++ prettyContradiction :: Document d => Contradiction -> d prettyContradiction contra = case contra of Cyclic -> text "cyclic"@@ -708,7 +741,7 @@ prettyProofMethod :: HighlightDocument d => ProofMethod -> d prettyProofMethod method = case method of- Attack -> keyword_ "SOLVED (trace found)"+ Attack -> keyword_ "SOLVED" <-> lineComment_ "trace found" Induction -> keyword_ "induction" Sorry reason -> fsep [keyword_ "sorry", lineComment_ reason] SolveGoal goal -> hsep [keyword_ "solve(", prettyGoal goal, keyword_ ")"]@@ -745,10 +778,12 @@ ppPrf prf -- | Convert a proof status to a redable string.-showProofStatus :: ProofStatus -> String-showProofStatus AttackFound = "attack found"-showProofStatus IncompleteProof = "incomplete proof"-showProofStatus CompleteProof = "complete proof"+showProofStatus :: SequentTraceQuantifier -> ProofStatus -> String+showProofStatus ExistsNoTrace TraceFound = "falsified - found trace"+showProofStatus ExistsNoTrace CompleteProof = "verified"+showProofStatus ExistsSomeTrace CompleteProof = "falsified - no trace found"+showProofStatus ExistsSomeTrace TraceFound = "verified"+showProofStatus _ IncompleteProof = "analysis incomplete" -- Derived instances
src/Theory/Proof/CaseDistinctions.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE DeriveDataTypeable, TupleSections, TypeOperators #-}-{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable, TupleSections, TypeOperators,+ TemplateHaskell, TypeSynonymInstances, FlexibleInstances,+ FlexibleContexts, GeneralizedNewtypeDeriving, ViewPatterns+ #-} -- | -- Copyright : (c) 2011,2012 Simon Meier -- License : GPL v3 (see LICENSE)@@ -32,21 +33,19 @@ import Safe import Prelude hiding ( (.), id )-import Debug.Trace import qualified Data.Set as S-import qualified Data.DAG.Simple as D import Data.Foldable (asum) import Control.Basics import Control.Category import Control.Monad.Disj-import Control.Monad.Bind+-- import Control.Monad.Bind import Control.Monad.Reader import Control.Monad.State (gets) import Control.Parallel.Strategies -import Text.Isar+import Text.PrettyPrint.Highlight import Extension.Prelude import Extension.Data.Label@@ -55,22 +54,6 @@ import Theory.Proof.Sequent --- | AC-Matching for big-step goals. MessageBigSteps can be matched--- to the corresponding K-up facts.-matchBigStepGoal :: BigStepGoal -- ^ Term.- -> BigStepGoal -- ^ Pattern.- -> WithMaude [LNSubst]-matchBigStepGoal (PremiseBigStep faTerm) (PremiseBigStep faPat) =- matchLNFact faTerm faPat-matchBigStepGoal (MessageBigStep mTerm) (MessageBigStep mPat) =- matchLNTerm [mTerm `MatchWith` mPat]-matchBigStepGoal (MessageBigStep mTerm) (PremiseBigStep faPat) =- case kFactView faPat of- Just (UpK, _, mPat) -> matchLNTerm [mTerm `MatchWith` mPat]- _ -> return []-matchBigStepGoal _ _ = return []-- ------------------------------------------------------------------------------ -- Big Step Proofs ------------------------------------------------------------------------------@@ -88,35 +71,23 @@ -- given typing assumptions are justified. initialCaseDistinction :: ProofContext -> [LNGuarded] -- ^ Typing assumptions.- -> BigStepGoal -> CaseDistinction-initialCaseDistinction ctxt typAsms goal =- CaseDistinction goal cases+ -> LNFact -> CaseDistinction+initialCaseDistinction ctxt typAsms goalFa =+ CaseDistinction goalFa cases where polish (((name, prem), se), _) = ([name], (prem, se)) se0 = set sFormulas (S.fromList typAsms) (emptySequent UntypedCaseDist)- cases = fmap polish $ runSeProof instantiate ctxt se0 (avoid (goal, se0))+ cases = fmap polish $ runSeProof instantiate ctxt se0 (avoid (goalFa, se0)) instantiate = do i <- freshLVar "i" LSortNode- let p = NodePrem (i, 0)+ let p = (i, PremIdx 0) err = error . ("requiresCasesThm: no or too many edges: " ++)- case goal of- PremiseBigStep fa -> do- name <- solveGoal (PremiseG p fa)- edges <- getM sEdges- case filter ((p ==) . eTgt) (S.toList edges) of- [e] -> do modM sEdges (S.delete e)- return (name, eSrc e)- es -> err $ show es-- -- FIXME: Probably this code is not required.- MessageBigStep m -> do- name <- solveGoal (PremUpKG p m)- edges <- getM sMsgEdges- case filter ((p ==) . meTgt) (S.toList edges) of- [e] -> do modM sMsgEdges (S.delete e)- return (name, meSrc e)- es -> err $ show es-+ name <- solveGoal (PremiseG p goalFa False)+ edges <- getM sEdges+ case filter ((p ==) . eTgt) (S.toList edges) of+ [e] -> do modM sEdges (S.delete e)+ return (name, eSrc e)+ es -> err $ show es -- | Refine a source case distinction by applying the additional proof step. refineCaseDistinction @@ -144,26 +115,22 @@ -- repeatedly simplifying the proof state. -- -- Returns the names of the steps applied.-solveAllSafeGoals - :: (LNFact -> Bool) -- ^ True, if this fact may be refined further.- -- Required for loop-breaking.- -> [CaseDistinction] - -> SeProof [String]-solveAllSafeGoals nonLoopingFact ths = +solveAllSafeGoals :: [CaseDistinction] -> SeProof [String]+solveAllSafeGoals ths = solve [] where- safeGoal _ (ChainG _) = True- safeGoal _ (PremDnKG _) = True- safeGoal _ (ActionG _ _) = True- safeGoal splitAllowed (DisjG _) = splitAllowed+ safeGoal _ (ChainG _) = True+ safeGoal _ (PremDnKG _) = True+ safeGoal _ (ActionG _ _) = True+ safeGoal splitAllowed (DisjG _) = splitAllowed -- NOTE: Uncomment the line below to get more extensive case splitting -- for precomputed case distinctions. -- safeGoal splitAllowed (SplitG _ _) = splitAllowed- safeGoal _ (PremiseG _ fa) = nonLoopingFact fa- safeGoal _ _ = False+ safeGoal _ (PremiseG _ fa mayLoop) = not (mayLoop || isKFact fa)+ safeGoal _ _ = False - nonLoopingGoal (PremiseG _ fa) = nonLoopingFact fa- nonLoopingGoal _ = True+ nonLoopingGoal (PremiseG _ _ mayLoop) = not mayLoop+ nonLoopingGoal _ = True solve caseNames = do simplifySequent@@ -188,48 +155,85 @@ Nothing -> return $ caseNames Just step -> solve . (caseNames ++) =<< step --- | Try to solve a premise goal using the first precomputed case distinction--- with a matching premise.++------------------------------------------------------------------------------+-- Applying precomputed case distinctions+------------------------------------------------------------------------------++-- | A goal for a big step case distinction.+data BigStepGoal = + PremiseBigStep NodePrem LNFact Bool+ | MessageBigStep (Either NodeId NodePrem) LNTerm+ -- ^ Left means solving a deduction action, Right a node premise.+ deriving( Eq, Ord, Show )++-- | Convert a standard goal to a big-step goal.+toBigStepGoal :: Goal -> Maybe BigStepGoal+toBigStepGoal goal = case goal of+ PremiseG p fa mayLoop -> return $ PremiseBigStep p fa mayLoop+ PremUpKG p m -> return $ MessageBigStep (Right p) m+ ActionG i (dedFactView -> Just m) -> return $ MessageBigStep (Left i) m+ _ -> mzero++fromBigStepGoal :: BigStepGoal -> Goal+fromBigStepGoal goal = case goal of+ PremiseBigStep p fa mayLoop -> PremiseG p fa mayLoop+ MessageBigStep (Left i) m -> ActionG i (dedLogFact m)+ MessageBigStep (Right p) m -> PremUpKG p m+++-- | AC-Matching for big-step goals. MessageBigSteps can be matched+-- to the corresponding K-up facts.+matchBigStepGoal :: BigStepGoal -- ^ Term.+ -> LNFact -- ^ Pattern.+ -> WithMaude [LNSubst]+matchBigStepGoal (PremiseBigStep _ faTerm _) faPat = matchLNFact faTerm faPat+matchBigStepGoal (MessageBigStep _ mTerm) faPat =+ case kFactView faPat of+ Just (UpK, _, mPat) -> matchLNTerm [mTerm `MatchWith` mPat]+ _ -> return []++-- | Try to solve a premise goal or 'Ded' action using the first precomputed+-- case distinction with a matching premise. solveWithCaseDistinction :: MaudeHandle -> [CaseDistinction] -> Goal -> Maybe (SeProof [String])-solveWithCaseDistinction hnd ths goal0 = case goal0 of - PremiseG p fa -> applyTo p (PremiseBigStep fa)- PremUpKG p m -> applyTo p (MessageBigStep m)- _ -> mzero- where- applyTo p goal = asum [ applyCaseDistinction hnd th p goal | th <- ths ]+solveWithCaseDistinction hnd ths goal0 = do+ goal <- toBigStepGoal goal0+ asum [ applyCaseDistinction hnd th goal | th <- ths ] -- | Apply a precomputed case distinction theorem to a required fact. applyCaseDistinction :: MaudeHandle- -> CaseDistinction -- ^ Case distinction theorem.- -> NodePrem -- ^ Premise+ -> CaseDistinction -- ^ Case distinction theorem. -> BigStepGoal -- ^ Required goal -> Maybe (SeProof [String])-applyCaseDistinction hnd th prem goal =+applyCaseDistinction hnd th goal = case (`runReader` hnd) $ matchBigStepGoal goal (get cdGoal th) of [] -> Nothing- _ -> Just $ do (names, subst, seTh) <- instTheorem `evalBindT` noBindings+ _ -> Just $ do (names, subst, seTh) <- instTheorem solveSubstEqs SplitNow subst conjoinSequent seTh return names where- instTheorem :: BindT LVar LVar SeProof ([String], LNSubst, Sequent)+ instTheorem :: SeProof ([String], LNSubst, Sequent) instTheorem = do- goalTh <- someInst $ get cdGoal th+ instTh <- rename th -- We only have to choose one matcher, as the theorem holds for all -- premises equal modulo AC. subst <- disjunctionOfList $ take 1 $ - matchBigStepGoal goal goalTh `runReader` hnd- (names, (concTh, seTh)) <- someInst =<< - (disjunctionOfList $ getDisj $ get cdCases th)+ matchBigStepGoal goal (get cdGoal instTh) `runReader` hnd+ (names, (concTh, seTh)) <- disjunctionOfList $ getDisj $ get cdCases instTh - let seTh' = case goal of- PremiseBigStep _ -> - modify sEdges (S.insert (Edge concTh prem)) seTh- MessageBigStep _ -> - modify sMsgEdges (S.insert (MsgEdge concTh prem)) seTh+ seTh' <- case goal of+ PremiseBigStep prem _ _ -> + return $ modify sEdges (S.insert (Edge concTh prem)) seTh+ MessageBigStep (Right prem) _ -> + return $ modify sMsgEdges (S.insert (MsgEdge concTh prem)) seTh+ MessageBigStep (Left i) m -> do+ -- remove solved atom+ modM sAtoms (S.delete (Action (varTerm i) (dedLogFact m)))+ return seTh -- solving the matcher equalities and -- conjoining the sequent will be done later@@ -243,8 +247,6 @@ saturateCaseDistinctions ctxt = go where- nonLoopingFact = saturationLoopBreakers ctxt- go ths = if any or (changes `using` parList rdeepseq) then go ths'@@ -252,7 +254,7 @@ where (changes, ths') = unzip $ map (refineCaseDistinction ctxt solver) ths noSplitThs = filter ((<= 1) . length . getDisj . get cdCases) ths- solver = do names <- solveAllSafeGoals nonLoopingFact noSplitThs+ solver = do names <- solveAllSafeGoals noSplitThs return (not $ null names, names) {-@@ -294,18 +296,18 @@ absFact (Fact tag ts) = (tag, length ts) - nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..n] ]+ nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..fromIntegral n] ] - someProtoGoal :: (FactTag, Int) -> BigStepGoal- someProtoGoal (tag, arity) = PremiseBigStep $ Fact tag (nMsgVars arity)+ someProtoGoal :: (FactTag, Int) -> LNFact+ someProtoGoal (tag, arity) = Fact tag (nMsgVars arity) - someKUGoal :: LNTerm -> BigStepGoal- someKUGoal m = PremiseBigStep (Fact KUFact [varTerm (LVar "f_" LSortMsg 0), m])+ someKUGoal :: LNTerm -> LNFact+ someKUGoal m = Fact KUFact [varTerm (LVar "f_" LSortMsg 0), m] -- FIXME: Also use facts from proof context. rules = get pcRules ctxt absProtoFacts = sortednub $ do- ru <- joinNonSpecialRules rules+ ru <- joinAllRules rules fa <- absFact <$> (getProtoFact =<< (get rConcs ru ++ get rPrems ru)) -- exclude facts handled specially by the prover guard (not $ fst fa `elem` [OutFact, InFact, FreshFact])@@ -313,11 +315,11 @@ absMsgFacts :: [LNTerm] absMsgFacts = asum $ sortednub $ - [ do return $ Lit $ Var (LVar "t" LSortFresh 1)+ [ do return $ lit $ Var (LVar "t" LSortFresh 1) - , [ FApp (NonAC (s,k)) $ nMsgVars k- | (s,k) <- funSigForMaudeSig . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt- , s `notElem` [ "inv", "pair" ] ]+ , [ fAppNonAC (s,k) $ nMsgVars k+ | (s,k) <- S.toList . allFunctionSymbols . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt+ , (s,k) `S.notMember` implicitFunSig, k > 0 ] ] -- | Refine a set of case distinction by exploiting additional typing@@ -338,51 +340,11 @@ set sCaseDistKind TypedCaseDist $ se removeFormulas = set sFormulas S.empty . set sSolvedFormulas S.empty --- Loop-breaker computation-------------------------------- | Compute the loop-breakers for saturating the pre-computated case--- distinctions.-saturationLoopBreakers :: ProofContext -> (LNFact -> Bool)-saturationLoopBreakers ctxt =- trace (" loop breakers: " ++ show (loopBreakers absProtoFactRel)) $- \fa -> absFact fa `S.notMember` loopBreakers absProtoFactRel- where- rules = get pcRules ctxt- -- detect cycles on abstracted protocol facts; i.e., (tag, arity) facts- absFact (Fact tag ts) = (tag, length ts)-- absProtoFactRel = sortednub $ do- ru <- joinNonSpecialRules rules- conc <- absFact <$> get rConcs ru- prem <- absFact <$> get rPrems ru- return (conc, prem)----- | Given a relation compute a set of loop-breakers; i.e., a feedback vertex--- set (<http://en.wikipedia.org/wiki/Feedback_vertex_set>). No guarantee for--- minimality is made. The current algorithm only removes self-loops and hopes--- that this is sufficient. We should implement something along the lines of--- Ann Becker, Dan Geiger, Optimization of Pearl's method of conditioning and--- greedy-like approximation algorithms for the vertex feedback set problem,--- Artificial Intelligence, Volume 83, Issue 1, May 1996, Pages 167-188, ISSN--- 0004-3702, 10.1016/0004-3702(95)00004-6.--- <http://www.sciencedirect.com/science/article/pii/0004370295000046>.-loopBreakers :: Ord a => [(a,a)] -> S.Set a-loopBreakers rel- | D.cyclic rel' = - error "loopBreakers: trivial loop-breaker computation failed.\- \The relation is still cyclic."- | otherwise = breakers- where- breakers = S.fromList [ x | (x, y) <- rel, x == y ]- rel' = [ r | r@(x, y) <- rel- , x `S.notMember` breakers, y `S.notMember` breakers]- ------------------------------------------------------------------------------ -- Pretty-printing ------------------------------------------------------------------------------ -prettyBigStepGoal :: Document d => BigStepGoal -> d-prettyBigStepGoal (PremiseBigStep fa) = prettyLNFact fa-prettyBigStepGoal (MessageBigStep m) = prettyLNTerm m+prettyBigStepGoal :: HighlightDocument d => BigStepGoal -> d+prettyBigStepGoal = prettyGoal . fromBigStepGoal++
src/Theory/Proof/EquationStore.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TypeOperators, TemplateHaskell, DeriveDataTypeable, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE TypeOperators, TemplateHaskell, DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables, TupleSections, ViewPatterns #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt -- License : GPL v3 (see LICENSE)@@ -15,6 +16,7 @@ , addRuleVariants , splitAtPos , eqSplits+ , splitCasenum , constrainedVarsPos , SplitStrategy(..)@@ -33,16 +35,15 @@ import Utils.Misc import Extension.Prelude --- import qualified Debug.Trace as DT- import Debug.Trace.Ignore import Data.List import Data.Label hiding ( for ) import Data.Maybe+import Safe import Data.Monoid-import Data.Traversable hiding ( mapM ) import qualified Data.Foldable as F+import qualified Data.Set as S import Control.Basics import Control.Monad.State hiding (get, modify) import qualified Control.Monad.State as MS@@ -51,19 +52,49 @@ -- Equation Store ---------------------------------------------------------------------- --- | We use an empty disjunction to denote false.-falseDisj :: Disj (LNSubstVFresh)-falseDisj = Disj []+-- | We use the empty set (disjunction) to denote false.+falseDisj :: S.Set LNSubstVFresh+falseDisj = S.empty +-- | 'SplitStrategy' denotes if the equation store should be split into+-- multiple equation stores. data SplitStrategy = SplitNow | SplitLater -- Dealing with equations ---------------------------------------------------------------------- --- | Returns the list of all @SplitId@s corresponding equation disjunctions.+-- | Returns the list of all @SplitId@s valid for the given equation store+-- sorted by the size of the disjunctions. eqSplits :: EqStore -> [SplitId]-eqSplits eqs = [0.. length (getConj . get eqsConj $ eqs) -1 ]+eqSplits eqs =+ map fst . sortOn snd $ zip [0..] (map S.size . getConj . get eqsConj $ eqs) ++-- | Returns the number of cases for a given 'SplitId'.+splitCasenum :: EqStore -> SplitId -> Int+splitCasenum eqs sid = case atMay (getConj . get eqsConj $ eqs) sid of+ Just disj -> S.size disj+ Nothing -> error "splitCasenum: invalid split id"+++-- | Add a disjunction to the equation store at the beginning+addDisj :: EqStore -> (S.Set LNSubstVFresh) -> EqStore+addDisj eqStore disj = modify eqsConj ((Conj [disj]) `mappend`) eqStore+++-- | @splitEqStoreAt eqs i@ takes the disjunction at position @i@ in @eqs@+-- and returns a list of resulting substitutions and the equality store+-- with the remaining equations.+splitAtPos :: EqStore -> Int -> Maybe [EqStore]+splitAtPos eqStore i+ | i `notElem` eqSplits eqStore = Nothing+ | otherwise = Just $ map (\d -> set eqsConj (conjNew d) eqStore) disj+ where+ conj = getConj $ get eqsConj eqStore+ disj = S.toList (conj !! i)+ conjNew d = Conj $ take i conj ++ [ S.singleton d ] ++ drop (i+1) conj++ -- | Add a list of term equalities to the equation store. -- Returns the resulting equation store(s) depending -- on the split strategy.@@ -71,35 +102,38 @@ -> [Equal LNTerm] -> EqStore -> m [EqStore] addEqs splitStrat hnd eqs0 eqStore = case unifyLNTermFactored eqs `runReader` hnd of- (_, []) -> return [set eqsConj falseEqConstrConj eqStore]- (subst, substs) ->- case splitStrat of- SplitLater ->- return $ [addDisj (applyEqStore hnd subst eqStore) (Disj substs)]- SplitNow -> - addEqsAC (modify eqsSubst (compose subst) eqStore)- <$> simpDisjunction hnd (Disj substs)+ (_, []) -> return [ set eqsConj falseEqConstrConj eqStore ]+ (subst, [ substFresh ]) | substFresh == emptySubstVFresh ->+ return [ applyEqStore hnd subst eqStore ]+ (subst, substs) ->+ case splitStrat of+ SplitLater ->+ return [ addDisj (applyEqStore hnd subst eqStore) (S.fromList substs) ]+ SplitNow ->+ addEqsAC (modify eqsSubst (compose subst) eqStore)+ <$> simpDisjunction hnd (const False) (Disj substs) where eqs = apply (get eqsSubst eqStore) $ trace (unlines ["addEqs: ", show eqs0]) $ eqs0- addEqsAC eqSt (sfree, Nothing) = [applyEqStore hnd sfree eqSt]+ addEqsAC eqSt (sfree, Nothing) = [ applyEqStore hnd sfree eqSt ] addEqsAC eqSt (sfree, Just disj) = fromMaybe (error "addEqsSplit: impossible, splitAtPos failed")- (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (Disj disj))) 0)+ (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (S.fromList disj))) 0) + -- | Apply a substitution to an equation store and bring resulting equations into -- normal form again by using unification. applyEqStore :: MaudeHandle -> LNSubst -> EqStore -> EqStore applyEqStore hnd asubst eqStore | dom asubst `intersect` varsRange asubst /= [] || trace (show ("applyEqStore", asubst, eqStore)) False- = error $ "applyS2EqStore: dom and vrange not disjoint for `"++show asubst++"'"+ = error $ "applyEqStore: dom and vrange not disjoint for `"++show asubst++"'" | otherwise- = modify eqsConj (fmap ((Disj . concatMap applyBound . getDisj))) $- set eqsSubst newsubst eqStore+ = modify eqsConj (fmap (S.fromList . concatMap applyBound . S.toList)) $+ set eqsSubst newsubst eqStore where newsubst = asubst `compose` get eqsSubst eqStore applyBound s = map (restrictVFresh (varsRange newsubst ++ domVFresh s)) $ (`runReader` hnd) $ unifyLNTerm- [ Equal (apply newsubst (varTerm $ lv)) t+ [ Equal (apply newsubst (varTerm lv)) t | let slist = substToListVFresh s, -- variables in the range are fresh, so we have to rename -- them away from all other variables in unification problem@@ -133,15 +167,16 @@ -} -- | Add the given rule variants.-addRuleVariants :: (Disj (LNSubstVFresh)) -> EqStore -> EqStore+addRuleVariants :: Disj LNSubstVFresh -> EqStore -> EqStore addRuleVariants (Disj substs) eqStore | dom freeSubst `intersect` concatMap domVFresh substs /= [] = error $ "addRuleVariants: Nonempty intersection between domain of variants and free substitution. " ++"This case has not been implemented, add rule variants earlier."- | otherwise = addDisj eqStore (Disj substs)+ | otherwise = addDisj eqStore (S.fromList substs) where freeSubst = get eqsSubst eqStore + -- | Return the set of variables that is constrained by disjunction at give position. constrainedVarsPos :: EqStore -> Int -> [LVar] constrainedVarsPos eqStore k@@ -150,26 +185,6 @@ where conj = getConj . get eqsConj $ eqStore --- Internal functions--------------------------------------------------------------------------- | Add a disjunction to the equation store at the beginning-addDisj :: EqStore -> (Disj (LNSubstVFresh)) -> EqStore-addDisj eqStore disj = modify eqsConj ((Conj [disj]) `mappend`) eqStore----- | @splitEqStoreAt eqs i@ takes the disjunction at position @i@ in @eqs@--- and returns a list of resulting substitutions and the equality store--- with the remaining equations.-splitAtPos :: EqStore -> Int -> Maybe [EqStore]-splitAtPos eqStore i- | i `notElem` eqSplits eqStore = Nothing- | otherwise = Just $ map (\d -> set eqsConj (conjNew d) eqStore) disj- where- conj = getConj $ get eqsConj eqStore- disj = getDisj $ conj !! i- conjNew d = Conj $ take i conj ++ [Disj [d]] ++ drop (i+1) conj- -- Simplifying disjunctions ---------------------------------------------------------------------- @@ -177,59 +192,59 @@ -- names for variables from the underlying 'MonadFresh'. simpDisjunction :: MonadFresh m => MaudeHandle- -> Disj (LNSubstVFresh)+ -> (LNSubstVFresh -> Bool)+ -> Disj LNSubstVFresh -> m (LNSubst, Maybe [LNSubstVFresh])-simpDisjunction hnd disj0 = do- eqStore' <- simp hnd eqStore+simpDisjunction hnd isContr disj0 = do+ eqStore' <- simp hnd isContr eqStore return (get eqsSubst eqStore', wrap $ get eqsConj eqStore') where- eqStore = set eqsConj (Conj [disj0]) $ emptyEqStore- wrap (Conj []) = Nothing- wrap (Conj [Disj disj]) = Just $ disj- wrap conj =+ eqStore = set eqsConj (Conj [ S.fromList . getDisj $ disj0 ]) $ emptyEqStore+ wrap (Conj []) = Nothing+ wrap (Conj [disj]) = Just $ S.toList disj+ wrap conj = error ("simplifyDisjunction: imposible, unexpected conjuction `" ++ show conj ++ "'") + -- Simplification ---------------------------------------------------------------------- -- | @simp eqStore@ simplifies the equation store.-simp :: MonadFresh m => MaudeHandle -> EqStore -> m EqStore-simp hnd eqStore = (`execStateT` (trace (show ("eqStore", eqStore)) eqStore)) $ whileTrue (simp1 hnd)+simp :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> EqStore -> m EqStore+simp hnd isContr eqStore =+ (`execStateT` (trace (show ("eqStore", eqStore)) eqStore)) $ whileTrue (simp1 hnd isContr) -- | @simp1@ tries to execute one simplification step -- for the equation store. It returns @True@ if -- the equation store was modified.-simp1 :: MonadFresh m => MaudeHandle -> StateT EqStore m Bool-simp1 hnd = do+simp1 :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> StateT EqStore m Bool+simp1 hnd isContr = do s <- MS.get- b1 <- simpMinimize- b2 <- simpRemoveRenamings- b3 <- simpEmptyDisj- b4 <- foreachDisj hnd simpSingleton- b5 <- foreachDisj hnd simpAbstractSortedVar- b6 <- foreachDisj hnd simpIdentify- b7 <- foreachDisj hnd simpAbstractFun- b8 <- foreachDisj hnd simpAbstractName- s' <- MS.get- (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8], s, s'))) $ return $ (or [b1, b2, b3, b4, b5, b6, b7, b8])+ if eqsIsFalse s+ then return False+ else do+ b1 <- simpMinimize isContr+ b2 <- simpRemoveRenamings+ b3 <- simpEmptyDisj+ b4 <- foreachDisj hnd simpSingleton+ b5 <- foreachDisj hnd simpAbstractSortedVar+ b6 <- foreachDisj hnd simpIdentify+ b7 <- foreachDisj hnd simpAbstractFun+ b8 <- foreachDisj hnd simpAbstractName+ (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8]))) $ return $ (or [b1, b2, b3, b4, b5, b6, b7, b8]) + -- | Remove variable renamings in fresh substitutions. simpRemoveRenamings :: MonadFresh m => StateT EqStore m Bool simpRemoveRenamings = do conj <- gets (get eqsConj)- let (conj',changed) =- runState (traverse (traverse rmRenamings) conj) False- when changed $ MS.modify (set eqsConj conj')- return changed- where - rmRenamings :: LNSubstVFresh -> State Bool LNSubstVFresh- rmRenamings subst = do- let subst' = removeRenamings subst- when (domVFresh subst /= domVFresh subst') $ put True- return subst'+ if F.any (S.foldl' (\b subst -> b || domVFresh subst /= domVFresh (removeRenamings subst)) False) conj+ then MS.modify (set eqsConj $ fmap (S.map removeRenamings) conj) >> return True+ else return False + -- | If empty disjunction is found, the whole conjunct -- can be simplified to False. simpEmptyDisj :: MonadFresh m => StateT EqStore m Bool@@ -239,45 +254,48 @@ then MS.modify (set eqsConj falseEqConstrConj) >> return True else return False + -- | If there is a singleton disjunction, it can be -- composed with the free substitution.-simpSingleton :: MonadFresh m => Disj LNSubstVFresh- -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh]))-simpSingleton (Disj [subst0]) = do- subst <- freshToFree subst0- return (Just (Just subst, []))-simpSingleton _ = return Nothing+simpSingleton :: MonadFresh m+ => [LNSubstVFresh]+ -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpSingleton [subst0] = do+ subst <- freshToFree subst0+ return (Just (Just subst, []))+simpSingleton _ = return Nothing -- | If all substitutions @si@ map a variable @v@ to terms with the same -- outermost function symbol @f@, then they all contain the common factor -- @{v |-> f(x1,..,xk)}@ for fresh variables xi and we can replace -- @x |-> ..@ by @{x1 |-> ti1, x2 |-> ti2, ..}@ in all substitutions @si@.-simpAbstractFun :: MonadFresh m => Disj LNSubstVFresh- -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh]))-simpAbstractFun (Disj []) = return Nothing-simpAbstractFun (Disj (subst:others)) = case commonOperators of- [] -> return Nothing+simpAbstractFun :: MonadFresh m+ => [LNSubstVFresh]+ -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractFun [] = return Nothing+simpAbstractFun (subst:others) = case commonOperators of+ [] -> return Nothing -- abstract all arguments (v, o, argss@(args:_)):_ | all ((==length args) . length) argss -> do fvars <- mapM (\_ -> freshLVar "x" LSortMsg) args let substs' = zipWith (abstractAll v fvars) (subst:others) argss- fsubst = substFromList [(v, FApp o (map varTerm fvars))]- return $ Just (Just $ fsubst, [Disj substs'])+ fsubst = substFromList [(v, fApp o (map varTerm fvars))]+ return $ Just (Just fsubst, [S.fromList substs']) -- abstract first two arguments (v, o@(AC _), argss):_ -> do fv1 <- freshLVar "x" LSortMsg fv2 <- freshLVar "x" LSortMsg let substs' = zipWith (abstractTwo o v fv1 fv2) (subst:others) argss- fsubst = substFromList [(v, FApp o (map varTerm [fv1,fv2]))]- return $ Just (Just $ fsubst, [Disj substs'])+ fsubst = substFromList [(v, fApp o (map varTerm [fv1,fv2]))]+ return $ Just (Just fsubst, [S.fromList substs']) (_, _ ,_):_ ->- error "simpAbstract: impossible, invalid arities or List operator encountered."+ error "simpAbstract: impossible, invalid arities or List operator encountered." where commonOperators = do- (v, FApp o args) <- substToListVFresh subst+ (v, viewTerm -> FApp o args) <- substToListVFresh subst let images = map (\s -> imageOfVFresh s v) others- argss = [ args' | Just (FApp o' args') <- images, o' == o ]+ argss = [ args' | Just (viewTerm -> FApp o' args') <- images, o' == o ] guard (length argss == length others) return (v, o, args:argss) @@ -292,72 +310,73 @@ newMappings [a1,a2] = [(fv1, a1), (fv2, a2)] -- here we always abstract from left to right and do not -- take advantage of the AC property of o- newMappings (a:as) = [(fv1, a), (fv2, FApp o as)]+ newMappings (a:as) = [(fv1, a), (fv2, fApp o as)] -- | If all substitutions @si@ map a variable @v@ to the same name @n@, -- then they all contain the common factor -- @{v |-> n}@ and we can remove @{v -> n} from all substitutions @si@-simpAbstractName :: MonadFresh m => Disj LNSubstVFresh- -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh]))-simpAbstractName (Disj []) = return Nothing-simpAbstractName (Disj (subst:others)) = case commonNames of+simpAbstractName :: MonadFresh m+ => [LNSubstVFresh]+ -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractName [] = return Nothing+simpAbstractName (subst:others) = case commonNames of [] -> return Nothing (v, c):_ -> return $ Just (Just $ substFromList [(v, c)]- , [Disj (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))])- + , [S.fromList (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))]) where commonNames = do- (v, c@(Lit (Con _))) <- substToListVFresh subst+ (v, c@(viewTerm -> Lit (Con _))) <- substToListVFresh subst let images = map (\s -> imageOfVFresh s v) others guard (length images == length [ () | Just c' <- images, c' == c]) return (v, c) + -- | If all substitutions @si@ map a variable @v@ to variables @xi@ of the same -- sort @s@ then they all contain the common factor -- @{v |-> y}@ for a fresh variable of sort @s@ -- and we can replace @{v -> xi}@ by @{y -> xi} in all substitutions @si@-simpAbstractSortedVar :: MonadFresh m => Disj LNSubstVFresh- -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh]))-simpAbstractSortedVar (Disj []) = return Nothing-simpAbstractSortedVar (Disj (subst:others)) = case commonSortedVar of+simpAbstractSortedVar :: MonadFresh m+ => [LNSubstVFresh]+ -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractSortedVar [] = return Nothing+simpAbstractSortedVar (subst:others) = case commonSortedVar of [] -> return Nothing (v, s, lvs):_ -> do fv <- freshLVar (lvarName v) s return $ Just (Just $ substFromList [(v, varTerm fv)]- , [Disj (zipWith (replaceMapping v fv) lvs (subst:others))])+ , [S.fromList (zipWith (replaceMapping v fv) lvs (subst:others))]) where commonSortedVar = do- (v, (Lit (Var lx))) <- substToListVFresh subst+ (v, (viewTerm -> Lit (Var lx))) <- substToListVFresh subst guard (sortCompare (lvarSort v) (lvarSort lx) == Just GT) let images = map (\s -> imageOfVFresh s v) others -- FIXME: could be generalized to choose topsort s of all images if s < sortOf v -- could also be generalized to terms of a given sort- goodImages = [ ly | Just (Lit (Var ly)) <- images, lvarSort lx == lvarSort ly]+ goodImages = [ ly | Just (viewTerm -> Lit (Var ly)) <- images, lvarSort lx == lvarSort ly] guard (length images == length goodImages) return (v, lvarSort lx, (lx:goodImages)) replaceMapping v fv lv sigma = substFromListVFresh $ (filter ((/=v) . fst) $ substToListVFresh sigma) ++ [(fv, varTerm lv)] -- -- | If all substitutions @si@ map two variables @x@ and @y@ to identical terms @ti@, -- then they all contain the common factor @{x |-> y} for a fresh variable @z@ -- and we can remove @{x |-> ti}@ from all @si@.-simpIdentify :: MonadFresh m => Disj (LNSubstVFresh)- -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh]))-simpIdentify (Disj []) = return Nothing-simpIdentify (Disj (subst:others)) = case equalImgPairs of+simpIdentify :: MonadFresh m+ => [LNSubstVFresh]+ -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpIdentify [] = return Nothing+simpIdentify (subst:others) = case equalImgPairs of [] -> return Nothing ((v,v'):_) -> do- let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of- Just GT -> (v', v)- Just _ -> (v, v')- Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: "- ++ show v ++" and "++ show v'- return $ Just (Just (substFromList [(vremove, varTerm vkeep)]),- [Disj (map (removeMappings [vkeep]) (subst:others))])+ let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of+ Just GT -> (v', v)+ Just _ -> (v, v')+ Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: "+ ++ show v ++" and "++ show v'+ return $ Just (Just (substFromList [(vremove, varTerm vkeep)]),+ [S.fromList (map (removeMappings [vkeep]) (subst:others))]) where equalImgPairs = do (v,t) <- substToListVFresh subst@@ -368,71 +387,38 @@ imageOfVFresh s v == imageOfVFresh s v' && isJust (imageOfVFresh s v) removeMappings vs s = restrictVFresh (domVFresh s \\ vs) s --- | Traverse disjunctions without msgBefore fact in conjunction and--- execute @f@ until it returns @Just (mfreeSubst, disjs)@.++-- | Simplify by removing substitutions that occur twice in a disjunct.+-- We could generalize this function by using AC-equality or subsumption.+simpMinimize :: MonadFresh m => (LNSubstVFresh -> Bool) -> StateT EqStore m Bool+simpMinimize isContr = do+ conj <- MS.gets (get eqsConj)+ if F.any (S.foldr (\subst b -> subst == emptySubstVFresh || isContr subst || b) False) conj+ then MS.modify (set eqsConj (fmap minimize conj)) >> return True+ else return False+ where minimize substs+ | emptySubstVFresh `S.member` substs = S.singleton emptySubstVFresh+ | otherwise = S.filter (not . isContr) substs+++-- | Traverse disjunctions and execute @f@ until it returns+-- @Just (mfreeSubst, disjs)@. -- Then the @disjs@ is inserted at the current position, if @mfreeSubst@ is -- @Just freesubst@, then it is applied to the equation store. @True@ is -- returned if any modifications took place. foreachDisj :: MonadFresh m => MaudeHandle- -> (Disj (LNSubstVFresh) -> m (Maybe (Maybe LNSubst, [Disj LNSubstVFresh])))+ -> ([LNSubstVFresh] -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))) -> StateT EqStore m Bool-foreachDisj hnd f = do- conj <- gets (get eqsConj)- go [] (getConj conj)+foreachDisj hnd f =+ go [] =<< gets (getConj . get eqsConj) where go _ [] = return False go lefts (d:rights) = do- b <- lift $ f d+ b <- lift $ f (S.toList d) case b of Nothing -> go (d:lefts) rights Just (msubst, disjs) -> do- MS.modify (set eqsConj (Conj (reverse lefts ++ disjs ++ rights)))- maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst- return True----- Renaming and subsumption--------------------------------------------------------------------------- | Simplify by removing substitutions that occur twice in a disjunct.--- We could generalize this function by using AC-equality or subsumption.-simpMinimize :: MonadFresh m => StateT EqStore m Bool-simpMinimize = do- eqs <- MS.get- let eqs' = modify eqsConj (fmap (Disj . sortednub . getDisj)) eqs- MS.put eqs'- return (eqs /= eqs')--{--- -t2 = simpAbstract (Disj (map substFromListVFresh [s1,s2])) `evalFresh` nothingUsed- where s1 = [(lx1,pair(y1,y2))]- s2 = [(lx1,pair(inv(y1),inv(y2)))]---t3 = simpAbstract (Disj (map substFromListVFresh [s1,s2,s3])) `evalFresh` nothingUsed- where s1 = [(lx1, mult [y1,y2] )]- s2 = [(lx1, mult [inv(y1), inv(y2), inv(y3)])]- s3 = [(lx1, mult[y5, y6, y7, y8])]---t4 = simpIdentify (Disj (map substFromListVFresh [s1,s2])) `evalFresh` nothingUsed- where s1 = [(lx1, mult [y1,y2,y3] ), (lx2, mult [y1,y2,y3] )]- s2 = [(lx1, mult [inv(y1), inv(y2), inv(y3)]), (lx2, mult [inv(y1), inv(y2), inv(y3)])]---}--{--t5 = simpAbstractFun (Disj (map substFromListVFresh [s1,s2,s3])) `evalFresh` nothingUsed- where s1 = [(lx1, mult [y1,y2] )]- s2 = [(lx1, x3)]- s3 = [(lx1, mult[y5, y6, y7, y8])]--t6 = simpIdentify (Disj (map substFromListVFresh [s1,s2,s3])) `evalFresh` nothingUsed- where s1 = [(lx1, mult [y1,y2,y3] ), (lx2, mult [y1,y2,y3] )]- s2 = [(lx1, mult [inv(y1), inv(y2), inv(y3)]), (lx2, mult [inv(y1), inv(y2), inv(y3)])]- s3 = [(lx1, y1), (lx2, y2)]---}+ MS.modify (set eqsConj (Conj (reverse lefts ++ disjs ++ rights)))+ maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst+ return True
src/Theory/Proof/Guarded.hs view
@@ -77,6 +77,7 @@ import Control.Monad.Fresh hiding ( mapM ) import Control.Arrow + ------------------------------------------------------------------------------ -- Types ------------------------------------------------------------------------------@@ -127,12 +128,12 @@ go (GGuarded qua ss as gf) = fGuarded qua ss as (go gf) -- | Fold a guarded formula with scope info.--- The Int argument denotes the number of+-- The Integer argument denotes the number of -- quantifiers that have been encountered so far.-foldGuardedScope :: (Int -> Atom (VTerm c (BVar v)) -> b)+foldGuardedScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Disj b -> b) -> (Conj b -> b)- -> (Quantifier -> [s] -> Int -> [Atom (VTerm c (BVar v))] -> b -> b)+ -> (Quantifier -> [s] -> Integer -> [Atom (VTerm c (BVar v))] -> b -> b) -> Guarded s c v -> b foldGuardedScope fAto fDisj fConj fGuarded =@@ -144,13 +145,13 @@ go !i (GGuarded qua ss as gf) = fGuarded qua ss i' as (go i' gf) where- i' = i + length ss+ i' = i + fromIntegral (length ss) -- | Map a guarded formula with scope info.--- The Int argument denotes the number of+-- The Integer argument denotes the number of -- quantifiers that have been encountered so far.-mapGuardedAtoms :: (Int -> Atom (VTerm c (BVar v))+mapGuardedAtoms :: (Integer -> Atom (VTerm c (BVar v)) -> Atom (VTerm d (BVar w))) -> Guarded s c v -> Guarded s d w@@ -162,9 +163,11 @@ -- Instances ------------------------------------------------------------------------------ +{- instance Functor (Guarded s c) where- fmap f = foldGuarded (GAto . fmap (fmap (fmap (fmap f)))) GDisj GConj- (\qua ss as gf -> GGuarded qua ss (map (fmap (fmap (fmap (fmap f)))) as) gf)+ fmap f = foldGuarded (GAto . fmap (fmapTerm (fmap (fmap f)))) GDisj GConj+ (\qua ss as gf -> GGuarded qua ss (map (fmap (fmapTerm (fmap (fmap f)))) as) gf)+-} instance Foldable (Guarded s c) where foldMap f = foldGuarded (foldMap (foldMap (foldMap (foldMap f))))@@ -172,16 +175,16 @@ (mconcat . getConj) (\_qua _ss as b -> foldMap (foldMap (foldMap (foldMap (foldMap f)))) as `mappend` b) --instance Traversable (Guarded s c) where- traverse f = foldGuarded (liftA GAto . traverse (traverse (traverse (traverse f))))- (liftA GDisj . sequenceA)- (liftA GConj . sequenceA)- (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverse (traverse (traverse f)))) as <*> gf)+traverseGuarded :: (Applicative f, Ord c, Ord v, Ord a)+ => (a -> f v) -> Guarded s c a -> f (Guarded s c v)+traverseGuarded f = foldGuarded (liftA GAto . traverse (traverseTerm (traverse (traverse f))))+ (liftA GDisj . sequenceA)+ (liftA GConj . sequenceA)+ (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverseTerm (traverse (traverse f)))) as <*> gf) -instance HasFrees (Guarded (String, LSort) c LVar) where- foldFrees f = foldMap (foldFrees f)- mapFrees f = traverse (mapFrees f)+instance Ord c => HasFrees (Guarded (String, LSort) c LVar) where+ foldFrees f = foldMap (foldFrees f)+ mapFrees f = traverseGuarded (mapFrees f) -- FIXME: remove name hints for variables for saturation?@@ -193,8 +196,8 @@ -- | @substBoundAtom s a@ substitutes each occurence of a bound variables @i@ -- in @dom(s)@ with the corresponding free variable @x=s(i)@ in the atom @a@.-substBoundAtom :: [(Int,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))-substBoundAtom s = fmap (fmap (fmap subst))+substBoundAtom :: Ord c => [(Integer,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))+substBoundAtom s = fmap (fmapTerm (fmap subst)) where subst bv@(Bound i') = case lookup i' s of Just x -> Free x Nothing -> bv@@ -203,15 +206,16 @@ -- | @substBound s gf@ substitutes each occurence of a bound -- variable @i@ in @dom(s)@ with the corresponding free variable -- @s(i)=x@ in all atoms in @gf@.-substBound :: [(Int,LVar)] -> LGuarded c -> LGuarded c+substBound :: Ord c => [(Integer,LVar)] -> LGuarded c -> LGuarded c substBound s = mapGuardedAtoms (\j a -> substBoundAtom [(i+j,v) | (i,v) <- s] a) -- | @substFreeAtom s a@ substitutes each occurence of a free variables @v@ -- in @dom(s)@ with the bound variables @i=s(v)@ in the atom @a@.-substFreeAtom :: [(LVar,Int)] +substFreeAtom :: Ord c+ => [(LVar,Integer)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))-substFreeAtom s = fmap (fmap (fmap subst))+substFreeAtom s = fmap (fmapTerm (fmap subst)) where subst fv@(Free x) = case lookup x s of Just i -> Bound i Nothing -> fv@@ -220,14 +224,14 @@ -- | @substFreeAtom s gf@ substitutes each occurence of a free variables -- @v in dom(s)@ with the correpsonding bound variables @i=s(v)@ -- in all atoms in @gf@.-substFree :: [(LVar,Int)] -> LGuarded c -> LGuarded c+substFree :: Ord c => [(LVar,Integer)] -> LGuarded c -> LGuarded c substFree s = mapGuardedAtoms (\j a -> substFreeAtom [(v,i+j) | (v,i) <- s] a) -- | Assuming that there are no more bound variables left in an atom of a -- formula, convert it to an atom with free variables only.-bvarToLVar :: Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar)+bvarToLVar :: Ord c => Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar) bvarToLVar = - fmap (fmap (fmap (foldBVar boundError id)))+ fmap (fmapTerm (fmap (foldBVar boundError id))) where boundError v = error $ "bvarToLVar: left-over bound variable '" ++ show v ++ "'"@@ -241,7 +245,7 @@ -- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is the -- succedent. In both antecedent and succedent, the bound variables are -- replaced by @vs@.-openGuarded :: (MonadFresh m)+openGuarded :: (Ord c, MonadFresh m) => LGuarded c -> m (Maybe (Quantifier, [LVar], [Atom (VTerm c LVar)], LGuarded c)) openGuarded (GGuarded qua vs as gf) = do xs <- mapM (\(n,s) -> freshLVar n s) vs@@ -253,10 +257,10 @@ openGuarded _ = return Nothing -- | @closeGuarded vs ats gf@ is a smart constructor for @GGuarded@.-closeGuarded :: Quantifier -> [LVar] -> [Atom (VTerm c LVar)] +closeGuarded :: Ord c => Quantifier -> [LVar] -> [Atom (VTerm c LVar)] -> LGuarded c -> LGuarded c closeGuarded qua vs as gf = GGuarded qua vs' as' gf'- where as' = map (substFreeAtom s . fmap (fmap (fmap Free))) as+ where as' = map (substFreeAtom s . fmap (fmapTerm (fmap Free))) as gf' = substFree s gf s = zip (reverse vs) [0..] vs' = map (lvarName &&& lvarSort) vs@@ -266,7 +270,7 @@ -- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is -- the succedent. In both antecedent and succedent, the bound variables are -- replaced by @vs@.-openAllGuarded :: (MonadFresh m)+openAllGuarded :: (Ord c, MonadFresh m) => LGuarded c -> m (Maybe ([LVar],[Atom (VTerm c LVar)], LGuarded c)) openAllGuarded = (fmap adapt) . openGuarded where@@ -277,7 +281,7 @@ -- existentially quantified trace formula and @Nothing@ otherwise. In the -- first case, @vs@ is a list of fresh variables and @gf'@ is the body of @gf@ -- with the bound variable replaced by @v@.-openExGuarded :: (MonadFresh m, Eq c) +openExGuarded :: (MonadFresh m, Eq c, Ord c) => LGuarded c -> m (Maybe ([LVar], LGuarded c)) openExGuarded (GGuarded Ex ss as gf0) = do xs <- mapM (uncurry freshLVar) ss@@ -545,7 +549,7 @@ pp gf0@(GGuarded _ _ _ _) = do Just (qua, vs, atoms, gf) <- openGuarded gf0- dante <- pp (GConj (Conj (map (GAto . fmap (fmap (fmap Free))) atoms)))+ dante <- pp (GConj (Conj (map (GAto . fmap (fmapTerm (fmap Free))) atoms))) dsucc <- pp gf return $ sep [ operator_ (show qua) <-> ppVars vs <> operator_ "." , nest 1 dante
src/Theory/Proof/Sequent.hs view
@@ -63,7 +63,7 @@ import Control.Monad.Bind import Control.Monad.State (StateT, runStateT, execStateT, gets, put) -import Text.Isar+import Text.PrettyPrint.Class import Extension.Prelude import Extension.Data.Label@@ -75,6 +75,8 @@ import Theory.Proof.Types import Theory.Proof.EquationStore +import Term.Rewriting.Norm (nf', maybeNotNfSubterms)+ ------------------------------------------------------------------------------ -- Sequents ------------------------------------------------------------------------------@@ -84,26 +86,45 @@ -- | Returns the sequent that has to be proven to show that -- given formula holds in the context of the given theory.-sequentFromFormula :: CaseDistKind -> LNFormula -> Sequent-sequentFromFormula kind f = +sequentFromFormula :: CaseDistKind -> SequentTraceQuantifier -> LNFormula -> Sequent+sequentFromFormula kind traceQuantifier f = set sFormulas (S.singleton gf) (emptySequent kind) where - gf = either error id (fromFormulaNegate f)+ adapt = case traceQuantifier of+ ExistsSomeTrace -> negateGuarded+ ExistsNoTrace -> id+ gf = either error id (adapt <$> fromFormulaNegate f) ------------------------------------------------------------------------------ -- Graph reasoning ------------------------------------------------------------------------------ --- | True iff there are terms in the sequent that are not in normal form wrt.+-- | True iff there are terms in the node constraints that are not in normal form wrt. -- to 'Term.Rewriting.Norm.norm' (DH/AC).------ FIXME: Might also want to check clauses, equation store, and other--- components of sequent. hasNonNormalTerms :: SignatureWithMaude -> Sequent -> Bool hasNonNormalTerms sig se =- any (not . (`runReader` (get sigmMaudeHandle sig)) . nfRule) . M.elems . get sNodes $ se+ any (not . (`runReader` hnd) . nf') (maybeNonNormalTerms hnd se)+ where hnd = get sigmMaudeHandle sig +-- | Returns all (sub)terms of node constraints that may be not in normal form.+maybeNonNormalTerms :: MaudeHandle -> Sequent -> [LNTerm]+maybeNonNormalTerms hnd se = + sortednub . concatMap getTerms . M.elems . get sNodes $ se+ where getTerms (Rule _ ps cs as) = do+ f <- ps++cs++as+ t <- factTerms f+ maybeNotNfSubterms (mhMaudeSig hnd) t++substCreatesNonNormalTerms :: MaudeHandle -> Sequent -> LNSubstVFresh -> Bool+substCreatesNonNormalTerms hnd se =+ \subst -> any (not . nfApply subst) terms+ where terms = maybeNonNormalTerms hnd se+ nfApply subst0 t = t == t' || nf' t' `runReader` hnd+ where tvars = freesList t+ subst = restrictVFresh tvars subst0+ t' = apply (freshToFreeAvoidingFast subst tvars) t+ -- | True if there is no @EXP-down@ rule that should be replaced by an -- @EXP-up@ rule. hasForbiddenExp :: Sequent -> Bool@@ -122,16 +143,16 @@ isForbiddenExp ru = maybe False id $ do [_,p2] <- return $ get rPrems ru [conc] <- return $ get rConcs ru- (UpK, _, b) <- kFactView p2- (DnK, Just IsExp, FApp (NonAC ("exp",2)) [g,c]) <- kFactView conc+ (UpK, _, b) <- kFactView p2+ (DnK, Just CannotExp, viewTerm2 -> FExp g c) <- kFactView conc -- g should be public and the required inputs for c already required by b guard (sortOfTerm g == LSortPub && (input c \\ input b == [])) return True where- sortOfTerm (Lit (Var lv)) = lvarSort lv- sortOfTerm (Lit (Con n)) = sortOfName n- sortOfTerm _ = LSortMsg+ sortOfTerm (viewTerm -> Lit (Var lv)) = lvarSort lv+ sortOfTerm (viewTerm -> Lit (Con n)) = sortOfName n+ sortOfTerm _ = LSortMsg -- | Compute all contradictions to unique fact instances.@@ -144,7 +165,7 @@ nonUniqueFactInstances :: SignatureWithMaude -> Sequent -> [(NodeId, NodeId, NodeId)] nonUniqueFactInstances sig se = do- Edge c@(NodeConc (i, _)) (NodePrem (k, _)) <- S.toList $ get sEdges se+ Edge c@(i, _) (k, _) <- S.toList $ get sEdges se let tag = factTag (nodeConcFact c se) guard (tag `S.member` get sigmUniqueInsts sig) j <- S.toList $ D.reachableSet [i] less@@ -219,7 +240,7 @@ -- | @proveLinearConc se (v,i)@ tries to prove that the @i@-th conclusion of node -- @v@ is a linear fact. proveLinearConc :: Sequent -> NodeConc -> Bool-proveLinearConc se (NodeConc (v,i)) =+proveLinearConc se (v,i) = maybe False (isLinearFact . (get (rConc i))) $ M.lookup v $ get sNodes se -- | Create a node labelled with a fresh instance of one of the rules and solve@@ -229,17 +250,17 @@ ruleNode :: NodeId -> [RuleAC] -> SeProof RuleACInst ruleNode i rules = do (ru, mrconstrs) <- importRule =<< disjunctionOfList rules- solveRuleConstraints mrconstrs i+ solveRuleConstraints mrconstrs modM sNodes (M.insert i ru) let inFacts = do- (v, Fact InFact [m]) <- zip [0..] $ get rPrems ru+ (v, Fact InFact [m]) <- enumPrems ru return $ do j <- freshLVar "vf" LSortNode ruKnows <- mkISendRuleAC m modM sNodes (M.insert j ruKnows)- modM sEdges (S.insert $ Edge (NodeConc (j,0)) (NodePrem (i,v)))+ modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i, v)) let freshFacts = do- (v, Fact FreshFact [m]) <- zip [0..] $ get rPrems ru+ (v, Fact FreshFact [m]) <- enumPrems ru return $ do j <- freshLVar "vf" LSortNode modM sNodes (M.insert j (mkFreshRuleAC m))@@ -247,7 +268,7 @@ -- 'm' must be of sort fresh n <- varTerm <$> freshLVar "n" LSortFresh solveTermEqs SplitNow [Equal m n]- modM sEdges (S.insert $ Edge (NodeConc (j,0)) (NodePrem (i,v)))+ modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i,v)) -- solve all Fr and In premises sequence_ inFacts sequence_ freshFacts@@ -255,9 +276,11 @@ where mkISendRuleAC m = do faPrem <- kuFact Nothing m- return $ Rule (ProtoInfo ISendRule) [faPrem] [inFact m] [kLogFact m]+ return $ Rule (IntrInfo (ISendRule))+ [faPrem] [inFact m] [kLogFact m] - mkFreshRuleAC m = Rule (ProtoInfo FreshRule) [] [freshFact m] []+ mkFreshRuleAC m = Rule (ProtoInfo (ProtoRuleACInstInfo FreshRule []))+ [] [freshFact m] [] -- | Create a fresh node labelled with a fresh instance of one of the rules -- and solve it's 'Fr' and 'In' facts immediatly.@@ -284,8 +307,8 @@ -> SeProof (RuleACInst, NodeConc, LNFact) freshRuleConc rules = do (i, ru) <- freshRuleNode rules- (v, fa) <- disjunctionOfList $ zip [0..] $ get rConcs ru- return (ru, NodeConc (i,v), fa)+ (v, fa) <- disjunctionOfList $ enumConcs ru+ return (ru, (i, v), fa) -- | Insert the edges and ensure the equality between the facts -- at either end of the edge.@@ -382,10 +405,10 @@ nodes <- M.toList <$> getM sNodes let (down, up) = partitionEithers $ do (i, ru) <- nodes- (v, fa) <- zip [0..] $ get rConcs ru+ (v, fa) <- enumConcs ru (d, _, m) <- maybe mzero return $ kFactView fa let tag = case d of UpK -> Right; DnK -> Left- return $ tag (m, (d, fa, NodeConc (i, v)))+ return $ tag (m, (d, fa, (i, v))) -- retain the up-entry if there are duplicates derived = M.fromList $ down ++ up @@ -395,7 +418,7 @@ trySolveGoal derived (PremUpKG p m) = trySolveMessage derived m (\c _ -> modM sMsgEdges (S.insert (MsgEdge c p))) - trySolveGoal derived (PremiseG p faPrem) = case kFactView faPrem of+ trySolveGoal derived (PremiseG p faPrem _mayLoop) = case kFactView faPrem of Just (UpK, _, m) -> trySolveMessage derived m -- For premise goals we have 'inp m == [m]'. We must insert a -- direct edge and ensure the equality wrt. an additional coerce@@ -410,8 +433,8 @@ Just (UpK, faConc, c) -> solveWith c faConc >> return True Just (DnK, faConc, c) -> do (j, (faPrem', faConc')) <- freshCoerceRuleNode- insertEdges [ (c, faConc , faPrem', NodePrem (j,0)) ]- _ <- solveWith (NodeConc (j,0)) faConc'+ insertEdges [ (c, faConc , faPrem', (j, PremIdx 0)) ]+ _ <- solveWith (j, ConcIdx 0) faConc' return True Nothing -> return False@@ -470,7 +493,7 @@ exploitFreshUnique = do -- gather fresh rule nodes and merge nodes with identical conclusions updates <- gets ( map merge- . groupSortOn (get (rConc 0) . snd)+ . groupSortOn (get (rConc (ConcIdx 0)) . snd) . filter (isFreshRule . snd) . M.toList . get sNodes@@ -495,27 +518,25 @@ exploitEdgeProps :: SeProof Bool -- True, if a simplification step happened. exploitEdgeProps = do se <- gets id- let edges = [ (getNodeConc src, getNodePrem prem)- | Edge src prem <- S.toList (get sEdges se) ]- rawEqs = mergeEqs fst snd edges ++- mergeEqs snd fst (filter (proveLinearConc se . NodeConc . fst) edges)- -- check if there are changes to be applied- if all null rawEqs- then do return False- else do- let eqs = concat rawEqs- -- all indices of merged premises and conclusions must be equal- contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs])- -- nodes must be equal- solveNodeIdEqs $ map (fmap fst) eqs- return True+ let edges = S.toList (get sEdges se)+ (||) <$> mergeNodes eSrc eTgt edges+ <*> mergeNodes eTgt eSrc (filter (proveLinearConc se . eSrc) edges) where- mergeEqs :: Ord c => (a -> b) -> (a -> c) -> [a] -> [[Equal b]]- mergeEqs what on = map (merge what) . groupSortOn on+ -- merge the nodes on the 'mergeEnd' for edges that are equal on the+ -- 'compareEnd'+ mergeNodes mergeEnd compareEnd edges+ | null eqs = return False+ | otherwise = do+ -- all indices of merged premises and conclusions must be equal+ contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs])+ -- nodes must be equal+ solveNodeIdEqs $ map (fmap fst) eqs+ return True+ where+ eqs = concatMap (merge mergeEnd) $ groupSortOn compareEnd edges - merge :: (a -> b) -> [a] -> [Equal b]- merge _ [] = error "exploitEdgeProps: impossible"- merge proj (keep:remove) = map (Equal (proj keep) . proj) remove+ merge _ [] = error "exploitEdgeProps: impossible"+ merge proj (keep:remove) = map (Equal (proj keep) . proj) remove -- | Merge nodes with equal non-pair msg conclusions.@@ -593,8 +614,8 @@ else modM sAtoms $ S.insert $ bvarToLVar $ Less j0 i0 Nothing -> [] where- nodeFromTerm (Lit (Var (Free v))) | lvarSort v == LSortNode = v- nodeFromTerm t = error $+ nodeFromTerm (viewTerm -> Lit (Var (Free v))) | lvarSort v == LSortNode = v+ nodeFromTerm t = error $ "expected free node variable, but got '" ++ show t ++ "'" @@ -636,8 +657,8 @@ mkEq i j = Equal (varTerm i) (varTerm j) mkOrdDisj i0 j0 = gdisj $ [GAto (EqE i j), GAto (Less i j)] where- i = Lit $ Var $ Free i0- j = Lit $ Var $ Free j0+ i = lit $ Var $ Free i0+ j = lit $ Var $ Free j0 -- | @setNodes nodes@ normalizes the @nodes@ such that node ids are unique and -- then updates the @sNodes@ field of the proof state to the corresponding map.@@ -737,7 +758,8 @@ solveTermEqs :: SplitStrategy -> [Equal LNTerm] -> SeProof () solveTermEqs splitStrat eqs = do hnd <- getMaudeHandle- setM sEqStore =<< simp hnd+ se <- gets id+ setM sEqStore =<< simp hnd (substCreatesNonNormalTerms hnd se) =<< disjunctionOfList =<< addEqs splitStrat hnd eqs =<< getM sEqStore@@ -775,14 +797,15 @@ -- | Solve the constraints associated with a rule with the given vertex.-solveRuleConstraints :: Maybe RuleACConstrs -> NodeId -> SeProof ()-solveRuleConstraints (Just eqConstr) _v = do+solveRuleConstraints :: Maybe RuleACConstrs -> SeProof ()+solveRuleConstraints (Just eqConstr) = do hnd <- getMaudeHandle setM sEqStore- =<< (simp hnd . addRuleVariants eqConstr)+ -- do not use expensive substCreatesNonNormalTerms here+ =<< (simp hnd (const False) . addRuleVariants eqConstr) =<< getM sEqStore noContradictoryEqStore-solveRuleConstraints Nothing _ = return ()+solveRuleConstraints Nothing = return () ------------------------------------------------------------------------------ -- Extracting and solving goals@@ -796,14 +819,15 @@ openPremiseGoals :: Sequent -> [(Usefulness, Goal)] openPremiseGoals se = do (i, ru) <- oneOfMap $ get sNodes se- (u, fa) <- zip [0..] $ get rPrems ru- let p = NodePrem (i, u)+ (u, fa) <- enumPrems ru+ let p = (i, u)+ breakers = ruleInfo (get praciLoopBreakers) (const []) $ get rInfo ru case fa of -- up-K facts (kFactView -> Just (UpK, _, m)) -> case input m of [m'] | m == m' -> do guard (not (trivial m') && (p, m') `S.notMember` coveredMsgPrems)- return $ markUseless m' i $ PremiseG p fa+ return $ markUseless m' i $ PremiseG p fa True m's -> do m' <- sortednub m's guard (not (trivial m') && (p, m') `S.notMember` coveredMsgPrems)@@ -815,7 +839,8 @@ | otherwise -> return . (Useful,) $ PremDnKG p -- all other facts _ | p `S.member` coveredPrems -> mzero- | otherwise -> return . (Useful,) $ PremiseG p fa+ | u `elem` breakers -> return . (Useless,) $ PremiseG p fa True+ | otherwise -> return . (Useful,) $ PremiseG p fa False where coveredPrems = S.fromList $ eTgt <$> S.toList (get sEdges se) <|> cTgt <$> S.toList (get sChains se)@@ -831,7 +856,7 @@ existingDeps = sRawLessRel se -- We use the following heuristic for marking KU-goals as useful (worth- -- solving now) or useless (to be delayed until no more useful goal+ -- solving now) or useless (to be delayed until no more useful goals -- remain). We ignore all goals that do not contain a fresh variable -- or where there exists a node, not after the premise or the last node, -- providing an Out or KD conclusion that provides the message we are@@ -847,7 +872,7 @@ toplevelTerms t@(destPair -> Just (t1, t2)) = t : toplevelTerms t1 ++ toplevelTerms t2- toplevelTerms t@(destInv -> Just t1) = t : toplevelTerms t1+ toplevelTerms t@(destInverse -> Just t1) = t : toplevelTerms t1 toplevelTerms t = [t] deducible = or $ do@@ -879,31 +904,71 @@ openSplitGoals se = SplitG <$> eqSplits (get sEqStore se) -- | All open action goals.+--+-- FIXME: Only `Ded` goals that are guaranteed to be a non-pair,+-- non-inversion, and non-product are considered open. This is wrong with+-- respect to our definition of a solved form of the constraint system. openActionGoals :: Sequent -> [Goal]-openActionGoals se = uncurry ActionG <$> sActionAtoms se+openActionGoals se = do+ (i, fa) <- sActionAtoms se+ case dedFactView fa of+ Just m | isPair m || isMsgVar m || isProduct m || isInverse m -> mzero+ _ -> return $ ActionG i fa -- | All open goals (non-deterministic choices of possible proof steps) in the -- sequent. openGoals :: Sequent -> [Goal]-openGoals se = delayUseless $ concat $+openGoals se = delayUseless $ sortDecisionTree solveFirst $ concat $ [ (Useful,) <$> openActionGoals se , (Useful,) <$> openDisjunctionGoals se , (Useful,) <$> openChainGoals se- , preferProtoFactGoals $ openPremiseGoals se+ , openPremiseGoals se -- SM: Commented out as automatic saturation works again. -- , (Useful,) <$> openImplicationGoals se , (Useful,) <$> openSplitGoals se ] where- isProtoFactGoal (_, PremiseG _ _) = True- isProtoFactGoal _ = False- preferProtoFactGoals goals =- uncurry (++) $ partition isProtoFactGoal goals+ solveFirst = map (. snd)+ [ isDisjGoal, isProtoFactGoal+ , isActionGoal+ , isChainGoal, isFreshKnowsGoal+ , isSplitGoalSmall, isDoubleExpGoal ] + isProtoFactGoal (PremiseG _ (Fact KUFact _) _) = False+ isProtoFactGoal (PremiseG _ _ _) = True+ isProtoFactGoal _ = False++ msgPremise (PremiseG _ (Fact KUFact [_, m]) _) = Just m+ msgPremise (PremUpKG _ m) = Just m+ msgPremise _ = Nothing++ isFreshKnowsGoal goal = case msgPremise goal of+ Just (viewTerm -> Lit (Var lv)) | lvarSort lv == LSortFresh -> True+ _ -> False++ isDoubleExpGoal goal = case msgPremise goal of+ Just (viewTerm2 -> FExp _ (viewTerm2 -> FMult _)) -> True+ _ -> False++ isSplitGoalSmall (SplitG sid) = splitCasenum (get sEqStore se) sid < 3+ isSplitGoalSmall _ = False+ delayUseless = map snd . sortOn fst +-- | @sortDecisionTree xs ps@ returns a reordering of @xs@+-- such that the sublist satisfying @ps!!0@ occurs first,+-- then the sublist satisfying @ps!!1@, and so on.+sortDecisionTree :: [a -> Bool] -> [a] -> [a]+sortDecisionTree [] xs = xs+sortDecisionTree (p:ps) xs = sat ++ sortDecisionTree ps nonsat+ where (sat, nonsat) = partition p xs+ -- | Solve an action goal.+--+-- PRE: If the action is a 'Ded' fact, then its argument must not be+-- instantiatable to a pair, inversion, or a product.+-- solveAction :: [RuleAC] -- ^ All rules labelled with an action -> (LVar, LNFact) -- ^ The action we are looking for. -> SeProof String -- ^ Sensible case name.@@ -911,10 +976,15 @@ modM sAtoms (S.delete (Action (varTerm i) fa)) mayRu <- M.lookup i <$> getM sNodes showRuleCaseName <$> case mayRu of- Nothing -> do ru <- ruleNode i rules- act <- disjunctionOfList $ get rActs ru- solveFactEqs SplitNow [Equal fa act]- return ru+ Nothing -> do -- case dedFactView fa of+ -- Just m -> do -- 'Ded' facts are dealt with specially.+ -- solvePremUpK + -- Nothing -> do + ru <- ruleNode i rules+ act <- disjunctionOfList $ get rActs ru+ solveFactEqs SplitNow [Equal fa act]+ return ru+ Just ru -> do unless (fa `elem` get rActs ru) $ do act <- disjunctionOfList $ get rActs ru solveFactEqs SplitNow [Equal fa act]@@ -955,11 +1025,11 @@ solvePremDnK rules p = do iLearn <- freshLVar "vl" LSortNode mLearn <- varTerm <$> freshLVar "t" LSortMsg- concLearn <- kdFact (Just IsNoExp) mLearn+ concLearn <- kdFact (Just CanExp) mLearn let premLearn = outFact mLearn- ruLearn = Rule (ProtoInfo IRecvRule) [premLearn] [concLearn] []- cLearn = NodeConc (iLearn, 0)- pLearn = NodePrem (iLearn, 0)+ ruLearn = Rule (IntrInfo IRecvRule) [premLearn] [concLearn] []+ cLearn = (iLearn, ConcIdx 0)+ pLearn = (iLearn, PremIdx 0) modM sNodes (M.insert iLearn ruLearn) modM sChains (S.insert (Chain cLearn p)) solvePremise rules pLearn premLearn@@ -978,16 +1048,16 @@ let m = case kFactView faConc of Just (DnK, _, m') -> m' _ -> error $ "solveChain: impossible"- caseName (FApp o _) = show o- caseName t = show t+ caseName (viewTerm -> FApp o _) = show o+ caseName t = show t return $ caseName m `disjunction` do -- extend it with one step (i, ru) <- freshRuleNode rules- (v, faPrem) <- disjunctionOfList $ zip [0..] $ get rPrems ru+ (v, faPrem) <- disjunctionOfList $ enumPrems ru solveFactEqs SplitNow [(Equal faPrem faConc)]- modM sEdges (S.insert (Edge c (NodePrem (i,v))))- modM sChains (S.insert (Chain (NodeConc (i,0)) p))+ modM sEdges (S.insert (Edge c (i, v)))+ modM sChains (S.insert (Chain (i, ConcIdx 0) p)) return $ showRuleCaseName ru ) @@ -998,7 +1068,8 @@ let errMsg = error "solveSplit: split of equations on unconstrained variable!" store <- maybe errMsg disjunctionOfList split hnd <- getMaudeHandle- store' <- simp hnd store+ se <- gets id+ store' <- simp hnd (substCreatesNonNormalTerms hnd se) store contradictoryIf (eqsIsFalse store') sEqStore =: store' return "split"@@ -1024,7 +1095,7 @@ trace (" solving goal: " ++ render (prettyGoal goal)) $ case goal of ActionG i fa -> solveAction (nonSilentRules rules) (i, fa) - PremiseG p fa -> + PremiseG p fa _mayLoop -> solvePremise (get crProtocol rules ++ get crConstruct rules) p fa PremDnKG p -> solvePremDnK (get crProtocol rules) p PremUpKG p m -> solvePremUpK (get crConstruct rules) p m
src/Theory/Proof/Sequent/Dot.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, TypeOperators #-}+{-# LANGUAGE TemplateHaskell, ViewPatterns, TypeOperators #-} -- | -- Copyright : (c) 2010, 2011 Simon Meier -- License : GPL v3 (see LICENSE)@@ -11,14 +11,17 @@ dotSequentLoose , dotSequentCompact , compressSequent+ , BoringNodeStyle(..) ) where import Safe import Data.Maybe+import Data.Char (isSpace) import Data.List import Data.Monoid (Any(..))-import qualified Data.Set as S-import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.DAG.Simple as D import Data.Color import Extension.Prelude@@ -29,12 +32,12 @@ import Control.Monad.Reader import qualified Text.Dot as D-import Text.Isar hiding (style)+import Text.PrettyPrint.Class import Theory.Rule import Theory.Proof.Sequent -type NodeColorMap = M.Map (RuleInfo ProtoRuleName IntrRuleACInfo) (HSV Double)+type NodeColorMap = M.Map (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) (HSV Double) type SeDot = ReaderT (Sequent, NodeColorMap) (StateT DotState D.Dot) -- | State to avoid multiple drawing of the same entity.@@ -104,16 +107,16 @@ nodeColor = maybe "white" (rgbToHex . lighter) color dot (label ru) [("fillcolor", nodeColor),("style","filled")] $ \vId -> do premIds <- mapM dotPrem- [ NodePrem (v,i) | (i,_) <- zip [0..] $ get rPrems ru ]- concIds <- mapM (dotConc . NodeConc) - [ (v,i) | (i,_) <- zip [0..] $ get rConcs ru ]+ [ (v,i) | (i,_) <- enumPrems ru ]+ concIds <- mapM dotConc + [ (v,i) | (i,_) <- enumConcs ru ] sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ] sequence_ [ dotIntraRuleEdge vId concId | concId <- concIds ] where label ru = " : " ++ render nameAndActs where nameAndActs = - ruleInfo prettyProtoRuleName prettyIntrRuleACInfo (get rInfo ru) <->+ ruleInfo (prettyProtoRuleName . get praciName) prettyIntrRuleACInfo (get rInfo ru) <-> brackets (vcat $ punctuate comma $ map prettyLNFact $ get rActs ru) -- | An edge from a rule node to its premises or conclusions.@@ -155,13 +158,13 @@ -- | Premises. dotPrem :: NodePrem -> SeDot D.NodeId-dotPrem prem@(NodePrem (v,i)) = +dotPrem prem@(v, i) = dotOnce dsPrems prem $ dotTrySingleEdge snd prem $ do nodes <- asks (get sNodes . fst) let ppPrem = show prem -- FIXME: Use better pretty printing here (label, moreStyle) = fromMaybe (ppPrem, []) $ do ru <- M.lookup v nodes- fa <- get rPrems ru `atMay` i+ fa <- lookupPrem i ru return ( render $ prettyLNFact fa , factNodeStyle fa )@@ -173,7 +176,7 @@ -- | Conclusions. dotConc :: NodeConc -> SeDot D.NodeId dotConc = - dotNodeWithIndex dsConcs fst rConcs getNodeConc "trapezium" + dotNodeWithIndex dsConcs fst rConcs (id *** getConcIdx) "trapezium" where dotNodeWithIndex stateSel edgeSel ruleSel unwrap shape x0 = dotOnce stateSel x0 $ dotTrySingleEdge edgeSel x0 $ do@@ -204,12 +207,12 @@ return (from, to) sequence_ $ do (v, ru) <- M.toList $ get sNodes se- (i, _) <- zip [0..] $ get rConcs ru- return (dotConc (NodeConc (v, i)))+ (i, _) <- enumConcs ru+ return (dotConc (v, i)) sequence_ $ do (v, ru) <- M.toList $ get sNodes se- (i, _) <- zip [0..] $ get rPrems ru- return (dotPrem (NodePrem (v,i)))+ (i, _) <- enumPrems ru+ return (dotPrem (v,i)) mapM_ dotNode $ M.keys $ get sNodes se mapM_ dotEdge $ S.toList $ get sEdges se mapM_ dotChain $ S.toList $ get sChains se@@ -293,46 +296,94 @@ -- Record based dotting ------------------------------------------------------------------------------ +-- | The style for nodes of the intruder.+data BoringNodeStyle = FullBoringNodes | CompactBoringNodes+ deriving( Eq, Ord, Show )++ -- | Dot a node in record based (compact) format.-dotNodeCompact :: NodeId -> SeDot D.NodeId-dotNodeCompact v = dotOnce dsNodes v $ do+dotNodeCompact :: BoringNodeStyle -> NodeId -> SeDot D.NodeId+dotNodeCompact boringStyle v = dotOnce dsNodes v $ do (se, colorMap) <- ask+ let hasOutgoingEdge = + or [ v == v' | Edge (v', _) _ <- S.toList $ get sEdges se ]+ || or [ v == v' | MsgEdge (v', _) _ <- S.toList $ get sMsgEdges se ] case M.lookup v $ get sNodes se of- Nothing -> liftDot $ D.node $ [("label", show v),("shape","ellipse")] + Nothing -> mkSimpleNode (show v) [] Just ru -> do let color = M.lookup (get rInfo ru) colorMap nodeColor = maybe "white" (rgbToHex . lighter) color attrs = [("fillcolor", nodeColor),("style","filled")]- (_, ids) <- liftDot $ D.record (mkRecord ru) attrs- let prems = [ (NodePrem (v, i), nid) | (Just (Left i), nid) <- ids ]- concs = [ (NodeConc (v, i), nid) | (Just (Right i), nid) <- ids ]+ ids <- mkNode ru attrs hasOutgoingEdge+ let prems = [ ((v, i), nid) | (Just (Left i), nid) <- ids ]+ concs = [ ((v, i), nid) | (Just (Right i), nid) <- ids ] modM dsPrems $ M.union $ M.fromList prems modM dsConcs $ M.union $ M.fromList concs return $ fromJust $ lookup Nothing ids where- mkRecord ru = D.vcat $ map D.hcat $ filter (not . null)- [ [ D.portField (Just (Left i)) (render (prettyLNFact p))- | (i, p) <- zip [(0::Int)..] $ get rPrems ru ]- , [ D.portField Nothing (show v ++ " : " ++ showRuleCaseName ru ++ acts) ]- , [ D.portField (Just (Right i)) (render (prettyLNFact c))- | (i, c) <- zip [(0::Int)..] $ get rConcs ru ]- ]++ mkSimpleNode lbl attrs = + liftDot $ D.node $ [("label", lbl),("shape","ellipse")] ++ attrs++ mkNode ru attrs hasOutgoingEdge+ -- single node, share node-id for all premises and conclusions+ | boringStyle == CompactBoringNodes && + (isIntruderRule ru || isFreshRule ru) = do+ let lbl | hasOutgoingEdge = show v ++ " : " ++ showRuleCaseName ru+ | otherwise = concatMap snd as+ nid <- mkSimpleNode lbl []+ return [ (key, nid) | (key, _) <- ps ++ as ++ cs ]+ -- full record syntax+ | otherwise =+ fmap snd $ liftDot $ (`D.record` attrs) $+ D.vcat $ map D.hcat $ map (map (uncurry D.portField)) $ + filter (not . null) [ps, as, cs] where- acts = (" " ++) $ render $- brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru- + ps = renderRow [ (Just (Left i), prettyLNFact p) | (i, p) <- enumPrems ru ]+ as = renderRow [ (Nothing, ruleLabel ) ]+ cs = renderRow [ (Just (Right i), prettyLNFact c) | (i, c) <- enumConcs ru ] + ruleLabel =+ prettyNodeId v <-> colon <-> text (showRuleCaseName ru) <>+ (brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)++ renderRow annDocs =+ zipWith (\(ann, _) lbl -> (ann, lbl)) annDocs $ + -- magic factor 1.3 compensates for space gained due to+ -- non-propertional font+ renderBalanced 100 (max 30 . round . (* 1.3)) (map snd annDocs)++ renderBalanced :: Double -- ^ Total available width+ -> (Double -> Int) -- ^ Convert available space to actual line-width.+ -> [Doc] -- ^ Initial documents+ -> [String] -- ^ Rendered documents+ renderBalanced _ _ [] = []+ renderBalanced totalWidth conv docs =+ zipWith (\w d -> widthRender (conv (ratio * w)) d) usedWidths docs+ where+ oneLineRender = renderStyle (defaultStyle { mode = OneLineMode })+ widthRender w = scaleIndent . renderStyle (defaultStyle { lineLength = w })+ usedWidths = map (fromIntegral . length . oneLineRender) docs+ ratio = totalWidth / sum usedWidths + scaleIndent line = case span isSpace line of+ (spaces, rest) -> + -- spaces are not wide-enough by default => scale them up+ let n = (1.5::Double) * fromIntegral (length spaces)+ in replicate (round n) ' ' ++ rest+++ -- | Dot a sequent in compact form (one record per rule)-dotSequentCompact :: Sequent -> D.Dot ()-dotSequentCompact se = +dotSequentCompact :: BoringNodeStyle -> Sequent -> D.Dot ()+dotSequentCompact boringStyle se = (`evalStateT` DotState M.empty M.empty M.empty M.empty) $ (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do liftDot $ setDefaultAttributes- mapM_ dotNodeCompact $ M.keys $ get sNodes se- mapM_ dotEdge $ S.toList $ get sEdges se- mapM_ dotChain $ S.toList $ get sChains se- mapM_ dotMsgEdge $ S.toList $ get sMsgEdges se- mapM_ dotLess $ sLessAtoms se+ mapM_ (dotNodeCompact boringStyle) $ M.keys $ get sNodes se+ mapM_ dotEdge $ S.toList $ get sEdges se+ mapM_ dotChain $ S.toList $ get sChains se+ mapM_ dotMsgEdge $ S.toList $ get sMsgEdges se+ mapM_ dotLess $ sLessAtoms se where missingNode shape label = liftDot $ D.node $ [("label", render label),("shape",shape)] dotPremC prem = dotOnce dsPrems prem $ missingNode "invtrapezium" $ prettyNodePrem prem@@ -340,7 +391,9 @@ dotEdge (Edge src tgt) = do let check p = maybe False p (resolveNodePremFact tgt se) || maybe False p (resolveNodeConcFact src se)- attrs | check isProtoFact = [("style","bold"),("weight","10.0")]+ attrs | check isProtoFact = + [("style","bold"),("weight","10.0")] +++ (guard (check isPersistentFact) >> [("color","gray50")]) | check isKFact = [("color","orangered2")] | otherwise = [("color","gray30")] dotGenEdge attrs src tgt@@ -349,7 +402,7 @@ srcId <- dotConcC src tgtId <- dotPremC tgt liftDot $ D.edge srcId tgtId style- + dotChain (Chain src tgt) = dotGenEdge [("style","dashed"),("color","green")] src tgt @@ -357,47 +410,50 @@ dotGenEdge [("style","dotted"),("color","orange")] src tgt dotLess (src, tgt) = do- srcId <- dotNodeCompact src- tgtId <- dotNodeCompact tgt+ srcId <- dotNodeCompact boringStyle src+ tgtId <- dotNodeCompact boringStyle tgt liftDot $ D.edge srcId tgtId [("color","black"),("style","dotted"),("constraint","false")] -- setting constraint to false ignores less-edges when ranking nodes. - {-- dotProvides (SeProvides v fa) = do- vId <- dotNodeCompact v- faId <- liftDot $ D.node [("label",label),("shape","trapezium")]- dotNonFixedIntraRuleEdge vId faId- where- label = render $ prettyLNFact fa- dotRequires (SeRequires v _fa) = do- _vId <- dotNodeCompact v- return ()- -- FIXME: Reenable- -- premId <- dotPremC (NodePremFact v fa)- -- dotNonFixedIntraRuleEdge premId vId- -} ------------------------------------------------------------------------------ -- Compressed versions of a sequent ------------------------------------------------------------------------------ +-- | Drop 'Less' atoms entailed by the edges of the 'Sequent'.+dropEntailedOrdConstraints :: Sequent -> Sequent+dropEntailedOrdConstraints se =+ modify sAtoms (S.filter (not . entailed)) se+ where+ edges = sRawEdgeRel se++ entailed (Less (viewTerm -> Lit (Var from)) (viewTerm -> Lit (Var to))) =+ to `S.member` D.reachableSet [from] edges+ entailed _ = False+ -- | Unsound compression of the sequent that drops fully connected learns and -- knows nodes. compressSequent :: Sequent -> Sequent-compressSequent se = +compressSequent se0 = foldl' (flip hideTransferNode) se $ [ x | x@(_, ru) <- M.toList $ get sNodes se- , isFreshRule ru || isDestrRule ru || isConstrRule ru || isIRecvRule ru || isISendRule ru ]+ , isFreshRule ru || isIntruderRule ru ]+ where+ se = dropEntailedOrdConstraints se0 -- | @hideTransferNode v se@ hides node @v@ in sequent @se@ if it is a--- transfer node; i.e., a node annotated with a rule with exactly one premise--- and one conclusion with exactly one incoming and one outgoing edge.+-- transfer node; i.e., a node annotated with a rule that is one of the+-- special intruder rules or a rule with with at most one premise and +-- at most one conclusion and both premises and conclusions have incoming+-- respectively outgoing edges.+--+-- The compression is chosen such that unly uninteresting nodes are that have+-- no open goal are suppressed. hideTransferNode :: (NodeId, RuleACInst) -> Sequent -> Sequent hideTransferNode (v, ru) se = fromMaybe se $ do guard $ - all (\l -> length (get l ru) <= 1) [rPrems, rConcs]- && (null $ get rActs ru)+ eligibleRule && (length eIns == length (get rPrems ru)) && (length eOuts == length (get rConcs ru)) && all (\(Edge cIn pOut) -> nodeConcNode cIn /= nodePremNode pOut) eNews@@ -413,6 +469,12 @@ $ modify sNodes (M.delete v) $ se where+ eligibleRule =+ any ($ ru) [isISendRule, isIRecvRule, isCoerceRule, isFreshRule] || + ( null (get rActs ru) && + all (\l -> length (get l ru) <= 1) [rPrems, rConcs]+ )+ selectPart :: (Sequent :-> S.Set a) -> (a -> Bool) -> [a] selectPart l p = filter p $ S.toList $ get l se
src/Theory/Proof/SolveGuarded.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, StandaloneDeriving, TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ -- spurious warnings for view patterns -- | -- Copyright : (c) 2011, 2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE)@@ -21,8 +24,6 @@ import Theory.Atom import Term.LTerm -import Term.Rewriting.NormAC- import Theory.Proof.Types import Data.Typeable@@ -93,10 +94,10 @@ modM sSolvedFormulas (S.insert fm) case bvarToLVar ato of EqE s t -- only add non-trivial equalities- | not (s ==# t) -> return $ Just $ Equal s t+ | not (s == t) -> return $ Just $ Equal s t | otherwise -> return Nothing- EdgeA (Lit (Var i), v) (Lit (Var j), u) -> do- modM sEdges $ S.insert $ Edge (NodeConc (i,v)) (NodePrem (j,u))+ EdgeA (viewTerm -> Lit (Var i), v) (viewTerm -> Lit (Var j), u) -> do+ modM sEdges $ S.insert $ Edge (i, v) (j, u) return Nothing EdgeA _ _ -> error $ "saturateGuarded: ill-formed edge atom: " ++ show ato@@ -164,15 +165,15 @@ hapBefore = happensBefore se atomHolds subst ato = case unskolemizeTerm . applySkTerm subst <$> ato of- Action _ _ -> True -- correct by construction- EqE t s -> t ==# s -- compare terms modulo AC- Last i -> Last i `S.member` get sAtoms se- DedBefore t (Lit (Var i)) -> t `dedBefore` i- Less (Lit (Var i)) (Lit (Var j)) -> i `hapBefore` j- EdgeA (Lit (Var i), v) (Lit (Var j), u) -> - Edge (NodeConc (i, v)) (NodePrem (j, u)) `S.member` get sEdges se+ Action _ _ -> True -- correct by construction+ EqE t s -> t == s -- compare terms modulo AC+ Last i -> Last i `S.member` get sAtoms se+ DedBefore t (viewTerm -> Lit (Var i)) -> t `dedBefore` i+ Less (viewTerm -> Lit (Var i)) (viewTerm -> Lit (Var j)) -> i `hapBefore` j+ EdgeA (viewTerm -> Lit (Var i), v) (viewTerm -> Lit (Var j), u) -> + Edge (i, v) (j, u) `S.member` get sEdges se -- play it safe and sound: all other atoms don't hold- _ -> False+ _ -> False -- Find open goals@@ -200,7 +201,7 @@ -------------------------------------------------- skolemizeTerm :: VTerm Name LVar -> SkTerm skolemizeTerm :: LNTerm -> SkTerm-skolemizeTerm = fmap conv+skolemizeTerm = fmapTerm conv where conv :: Lit Name LVar -> Lit SkConst LVar conv (Var v) = Con (SkConst v)@@ -216,7 +217,7 @@ skolemizeGuarded = mapGuardedAtoms (const skolemizeAtom) unskolemizeTerm :: SkTerm -> VTerm Name LVar-unskolemizeTerm t = fmap conv t+unskolemizeTerm t = fmapTerm conv t where conv :: Lit SkConst LVar -> Lit Name LVar conv (Con (SkConst x)) = Var x@@ -238,7 +239,7 @@ ---------------------------------------------- skolemizeBTerm :: VTerm Name BLVar -> BSkTerm-skolemizeBTerm = fmap conv+skolemizeBTerm = fmapTerm conv where conv :: Lit Name BLVar -> Lit SkConst BLVar conv (Var (Free x)) = Con (SkConst x)@@ -246,7 +247,7 @@ conv (Con n) = Con (SkName n) unskolemizeBTerm :: BSkTerm -> VTerm Name BLVar-unskolemizeBTerm t = fmap conv t+unskolemizeBTerm t = fmapTerm conv t where conv :: Lit SkConst BLVar -> Lit Name BLVar conv (Con (SkConst x)) = Var (Free x)@@ -262,12 +263,14 @@ unskolemizeLNGuarded = mapGuardedAtoms (const unskolemizeBLAtom) applyBSkTerm :: SkSubst -> VTerm SkConst BLVar -> VTerm SkConst BLVar-applyBSkTerm subst t = (>>= applyBLLit) t+applyBSkTerm subst t = go t where+ go (viewTerm -> Lit l) = applyBLLit l+ go (viewTerm -> FApp o as) = fApp o (map go as) applyBLLit :: Lit SkConst BLVar -> VTerm SkConst BLVar applyBLLit l@(Var (Free v)) =- maybe (Lit l) (fmap (fmap Free)) (imageOf subst v)- applyBLLit l = Lit l+ maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v)+ applyBLLit l = lit l applyBSkAtom :: SkSubst -> Atom (VTerm SkConst BLVar) -> Atom (VTerm SkConst BLVar) applyBSkAtom subst = fmap (applyBSkTerm subst)
src/Theory/Proof/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable, TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, ViewPatterns #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE)@@ -14,8 +15,8 @@ -- * Graph part of a sequent NodeId- , NodePrem(..)- , NodeConc(..)+ , NodePrem+ , NodeConc , Edge(..) , MsgEdge(..) , Chain(..)@@ -39,6 +40,13 @@ -- * Goals , Goal(..)+ , isActionGoal+ , isPremiseGoal+ , isPremDnKGoal+ , isPremUpKGoal+ , isChainGoal+ , isSplitGoal+ , isDisjGoal -- * Keeping track of typing , CaseDistKind(..)@@ -67,6 +75,7 @@ , sLastAtoms , sDedBeforeAtoms , sActions+ , sRawEdgeRel , sRawLessRel , sRawGreaterRel , deducibleBefore@@ -99,11 +108,15 @@ -- * Proof context , ProofContext(..)+ , InductionHint(..)+ , SequentTraceQuantifier(..) , pcSignature , pcRules , pcCaseDists-+ , pcCaseDistKind+ , pcUseInduction+ , pcTraceQuantifier -- ** Classified rules , ClassifiedRules(..)@@ -111,15 +124,12 @@ , crConstruct , crDestruct , crProtocol- , crSpecial , joinAllRules- , joinNonSpecialRules , nonSilentRules -- ** Big-step case distinctions -- | See the module "Theory.Proof.CaseDistinction" for ways -- to construct case distinctions.- , BigStepGoal(..) , CaseDistinction(..) , cdGoal@@ -135,8 +145,6 @@ import Prelude hiding ( (.), id ) -import Safe- import Data.Maybe (mapMaybe, fromMaybe) import qualified Data.Set as S import qualified Data.Map as M@@ -152,7 +160,7 @@ import Control.Category import Control.Basics -import Text.Isar+import Text.PrettyPrint.Class import Logic.Connectives @@ -170,13 +178,11 @@ -- rules modulo AC. We identify these nodes using 'NodeId's. type NodeId = LVar --- | A premise (index) of a node.-newtype NodePrem = NodePrem { getNodePrem :: (NodeId, Int) }- deriving( Eq, Ord, Show, Data, Typeable )+-- | A premise of a node.+type NodePrem = (NodeId, PremIdx) --- | A conclusion (index) of a node.-newtype NodeConc = NodeConc { getNodeConc :: (NodeId, Int) }- deriving( Eq, Ord, Show, Data, Typeable )+-- | A conclusion of a node.+type NodeConc = (NodeId, ConcIdx) -- | A labeled edge in a derivation graph. data Edge = Edge {@@ -203,12 +209,6 @@ -- Instances ------------ -instance Apply NodePrem where- apply subst = NodePrem . first (apply subst) . getNodePrem--instance Apply NodeConc where- apply subst = NodeConc . first (apply subst) . getNodeConc- instance Apply Edge where apply subst (Edge from to) = Edge (apply subst from) (apply subst to) @@ -218,16 +218,6 @@ instance Apply Chain where apply subst (Chain from to) = Chain (apply subst from) (apply subst to) -instance HasFrees NodePrem where- foldFrees f = foldFrees f . fst . getNodePrem- mapFrees f (NodePrem (v, i)) = - NodePrem <$> ((,) <$> mapFrees f v <*> pure i)--instance HasFrees NodeConc where- foldFrees f = foldFrees f . fst . getNodeConc- mapFrees f (NodeConc (v, i)) = - NodeConc <$> ((,) <$> mapFrees f v <*> pure i)- instance HasFrees Edge where foldFrees f (Edge x y) = foldFrees f x `mappend` foldFrees f y mapFrees f (Edge x y) = Edge <$> mapFrees f x <*> mapFrees f y@@ -274,7 +264,7 @@ -- @s@ in the disjunction with @x `elem` dom s@. data EqStore = EqStore { _eqsSubst :: LNSubst- , _eqsConj :: Conj (Disj (LNSubstVFresh))+ , _eqsConj :: Conj (S.Set LNSubstVFresh) } deriving( Eq, Ord ) @@ -289,8 +279,8 @@ eqsIsFalse = (== falseEqConstrConj) . L.get eqsConj -- | The false typing conjunction.-falseEqConstrConj :: Conj (Disj (LNSubstVFresh))-falseEqConstrConj = Conj [(Disj [])]+falseEqConstrConj :: Conj (S.Set (LNSubstVFresh))+falseEqConstrConj = Conj [S.empty] -- Instances@@ -316,8 +306,11 @@ data Goal = ActionG LVar LNFact -- ^ An action that must exist in the trace.- | PremiseG NodePrem LNFact- -- ^ A premise that must have an incoming direct edge.+ | PremiseG NodePrem LNFact Bool+ -- ^ A premise that must have an incoming direct edge. The 'Bool'+ -- argument is 'True' if this premise is marked as a loop-breaker;+ -- i.e., if care must be taken to avoid solving such a premise too+ -- often. | PremDnKG NodePrem -- ^ A KD goal that must be solved using a destruction chain. | PremUpKG NodePrem LNTerm@@ -336,40 +329,73 @@ -- out. deriving( Eq, Ord, Show ) +-- Indicators+-------------++isActionGoal :: Goal -> Bool+isActionGoal (ActionG _ _) = True+isActionGoal _ = False++isPremiseGoal :: Goal -> Bool+isPremiseGoal (PremiseG _ _ _) = True+isPremiseGoal _ = False++isPremDnKGoal :: Goal -> Bool+isPremDnKGoal (PremDnKG _) = True+isPremDnKGoal _ = False++isPremUpKGoal :: Goal -> Bool+isPremUpKGoal (PremUpKG _ _) = True+isPremUpKGoal _ = False++isChainGoal :: Goal -> Bool+isChainGoal (ChainG _) = True+isChainGoal _ = False++isSplitGoal :: Goal -> Bool+isSplitGoal (SplitG _) = True+isSplitGoal _ = False++isDisjGoal :: Goal -> Bool+isDisjGoal (DisjG _) = True+isDisjGoal _ = False+++ -- Instances ------------ instance HasFrees Goal where foldFrees f goal = case goal of- ActionG i fa -> foldFrees f i `mappend` foldFrees f fa- PremiseG p fa -> foldFrees f p `mappend` foldFrees f fa- PremDnKG p -> foldFrees f p- PremUpKG p m -> foldFrees f p `mappend` foldFrees f m- ChainG ch -> foldFrees f ch- SplitG i -> foldFrees f i- DisjG x -> foldFrees f x- ImplG x -> foldFrees f x+ ActionG i fa -> foldFrees f i `mappend` foldFrees f fa+ PremiseG p fa mayLoop -> foldFrees f p `mappend` foldFrees f fa `mappend` foldFrees f mayLoop+ PremDnKG p -> foldFrees f p+ PremUpKG p m -> foldFrees f p `mappend` foldFrees f m+ ChainG ch -> foldFrees f ch+ SplitG i -> foldFrees f i+ DisjG x -> foldFrees f x+ ImplG x -> foldFrees f x mapFrees f goal = case goal of- ActionG i fa -> ActionG <$> mapFrees f i <*> mapFrees f fa- PremiseG p fa -> PremiseG <$> mapFrees f p <*> mapFrees f fa- PremDnKG p -> PremDnKG <$> mapFrees f p- PremUpKG p m -> PremUpKG <$> mapFrees f p <*> mapFrees f m- ChainG ch -> ChainG <$> mapFrees f ch- SplitG i -> SplitG <$> mapFrees f i- DisjG x -> DisjG <$> mapFrees f x- ImplG x -> ImplG <$> mapFrees f x+ ActionG i fa -> ActionG <$> mapFrees f i <*> mapFrees f fa+ PremiseG p fa mayLoop -> PremiseG <$> mapFrees f p <*> mapFrees f fa <*> mapFrees f mayLoop+ PremDnKG p -> PremDnKG <$> mapFrees f p+ PremUpKG p m -> PremUpKG <$> mapFrees f p <*> mapFrees f m+ ChainG ch -> ChainG <$> mapFrees f ch+ SplitG i -> SplitG <$> mapFrees f i+ DisjG x -> DisjG <$> mapFrees f x+ ImplG x -> ImplG <$> mapFrees f x instance Apply Goal where apply subst goal = case goal of- ActionG i fa -> ActionG (apply subst i) (apply subst fa)- PremiseG p fa -> PremiseG (apply subst p) (apply subst fa)- PremDnKG p -> PremDnKG (apply subst p)- PremUpKG p m -> PremUpKG (apply subst p) (apply subst m)- ChainG ch -> ChainG (apply subst ch)- SplitG i -> SplitG (apply subst i)- DisjG x -> DisjG (apply subst x)- ImplG x -> ImplG (apply subst x)+ ActionG i fa -> ActionG (apply subst i) (apply subst fa)+ PremiseG p fa mayLoop -> PremiseG (apply subst p) (apply subst fa) (apply subst mayLoop)+ PremDnKG p -> PremDnKG (apply subst p)+ PremUpKG p m -> PremUpKG (apply subst p) (apply subst m)+ ChainG ch -> ChainG (apply subst ch)+ SplitG i -> SplitG (apply subst i)+ DisjG x -> DisjG (apply subst x)+ ImplG x -> ImplG (apply subst x) ------------------------------------------------------------------------------@@ -449,33 +475,37 @@ malformed ato = error $ "malformed atom in sequent: " ++ show ato - aLess (Less (Lit (Var from)) (Lit (Var to))) = Just (from, to)+ aLess (Less (viewTerm -> Lit (Var from)) (viewTerm -> Lit (Var to))) = Just (from, to) aLess ato@(Less _ _) = malformed ato aLess _ = Nothing - aAction (Action (Lit (Var i)) fa) = Just (i, fa)+ aAction (Action (viewTerm -> Lit (Var i)) fa) = Just (i, fa) aAction ato@(Action _ _) = malformed ato aAction _ = Nothing - aLast (Last (Lit (Var i))) = Just i+ aLast (Last (viewTerm -> Lit (Var i))) = Just i aLast ato@(Last _) = malformed ato aLast _ = Nothing - aDedBefore (DedBefore t (Lit (Var i))) = Just (t, i)+ aDedBefore (DedBefore t (viewTerm -> Lit (Var i))) = Just (t, i) aDedBefore ato@(DedBefore _ _) = malformed ato aDedBefore _ = Nothing ---- | @(from,to)@ is in @sRawLessRel se@ iff we can prove that there is a path--- from @from@ to @to@ in @se@ without appealing to transitivity.-sRawLessRel :: Sequent -> [(NodeId,NodeId)]-sRawLessRel se =- sLessAtoms se +++-- | @(from,to)@ is in @sRawEdgeRel se@ iff we can prove that there is an+-- edge-path from @from@ to @to@ in @se@ without appealing to transitivity.+sRawEdgeRel :: Sequent -> [(NodeId, NodeId)]+sRawEdgeRel se = map (nodeConcNode *** nodePremNode) ([ (from, to) | Edge from to <- S.toList $ L.get sEdges se ] ++ [ (from, to) | MsgEdge from to <- S.toList $ L.get sMsgEdges se ] ++ [ (from, to) | Chain from to <- S.toList $ L.get sChains se ]) +-- | @(from,to)@ is in @sRawLessRel se@ iff we can prove that there is a path+-- (possibly using the 'Less' relation) from @from@ to @to@ in @se@ without+-- appealing to transitivity.+sRawLessRel :: Sequent -> [(NodeId,NodeId)]+sRawLessRel se = sLessAtoms se ++ sRawEdgeRel se+ -- | 'sRawGreaterRel' is the inverse of 'sRawLessRel'. sRawGreaterRel :: Sequent -> [(NodeId,NodeId)] sRawGreaterRel = map (\(x,y) -> (y,x)) . sRawLessRel@@ -554,16 +584,15 @@ -- sequent @se@ under the assumption that premise @prem@ is a a premise in -- @se@. nodePremFact :: NodePrem -> Sequent -> LNFact-nodePremFact (NodePrem (v, i)) se = L.get (rPrem i) $ nodeRule v se+nodePremFact (v, i) se = L.get (rPrem i) $ nodeRule v se -- | @nodePremNode prem@ is the node that this premise is referring to. nodePremNode :: NodePrem -> NodeId-nodePremNode (NodePrem (v, _)) = v+nodePremNode = fst -- | All facts associated to this node premise. resolveNodePremFact :: NodePrem -> Sequent -> Maybe LNFact-resolveNodePremFact (NodePrem (v, i)) se = - (`atMay` i) =<< L.get rPrems <$> M.lookup v (L.get sNodes se)+resolveNodePremFact (v, i) se = lookupPrem i =<< M.lookup v (L.get sNodes se) {- -- | All msg fact premises required by the sequent for the given node premise.@@ -573,8 +602,7 @@ -- | The fact associated with this node conclusion, if there is one. resolveNodeConcFact :: NodeConc -> Sequent -> Maybe LNFact-resolveNodeConcFact (NodeConc (v, i)) se = - (`atMay` i) =<< L.get rConcs <$> M.lookup v (L.get sNodes se)+resolveNodeConcFact (v, i) se = lookupConc i =<< M.lookup v (L.get sNodes se) {- -- | The msg fact provided by the sequent for the given node conclusion@@ -586,11 +614,11 @@ -- rule associated with node @v@ under the assumption that @v@ is labeled with -- a rule that has an @i@-th conclusion. nodeConcFact :: NodeConc -> Sequent -> LNFact-nodeConcFact (NodeConc (v, i)) = L.get (rConc i) . nodeRule v+nodeConcFact (v, i) = L.get (rConc i) . nodeRule v -- | 'nodeConcNode' @c@ compute the node-id of the node conclusion @c@. nodeConcNode :: NodeConc -> NodeId-nodeConcNode = fst . getNodeConc+nodeConcNode = fst -- | Label to access the free substitution of the equation store. sSubst :: Sequent :-> LNSubst@@ -598,7 +626,7 @@ -- | Label to access the conjunction of disjunctions of fresh substutitution in -- the equation store.-sConjDisjEqs :: Sequent :-> Conj (Disj (LNSubstVFresh))+sConjDisjEqs :: Sequent :-> Conj (S.Set (LNSubstVFresh)) sConjDisjEqs = eqsConj . sEqStore @@ -616,11 +644,11 @@ -- | Pretty print a node conclusion. prettyNodeConc :: HighlightDocument d => NodeConc -> d-prettyNodeConc (NodeConc (v, i)) = parens (prettyNodeId v <> comma <-> int i)+prettyNodeConc (v, ConcIdx i) = parens (prettyNodeId v <> comma <-> int i) -- | Pretty print a node premise. prettyNodePrem :: HighlightDocument d => NodePrem -> d-prettyNodePrem (NodePrem (v, i)) = parens (prettyNodeId v <> comma <-> int i)+prettyNodePrem (v, PremIdx i) = parens (prettyNodeId v <> comma <-> int i) -- | Pretty print a edge as @src >-i--j-> tgt@. prettyEdge :: HighlightDocument d => Edge -> d@@ -677,21 +705,23 @@ ] where combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]- ppDisj (Disj substs) =+ ppDisj substs = numbered' conjs where - conjs = map ppConj substs+ conjs = map ppConj (S.toList substs) ppConj = vcat . map prettyEq . substToListVFresh prettyEq (a,b) = - prettyNTerm (Lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b)+ prettyNTerm (lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b) -- | Pretty print a goal. prettyGoal :: HighlightDocument d => Goal -> d-prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa)-prettyGoal (ChainG ch) = prettyChain ch-prettyGoal (PremiseG p fa) = prettyNodePrem p <> brackets (prettyLNFact fa)-prettyGoal (PremDnKG p) = text "KD" <> parens (prettyNodePrem p)-prettyGoal (ImplG gf) = +prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa)+prettyGoal (ChainG ch) = prettyChain ch+prettyGoal (PremiseG p fa mayLoop) =+ prettyNodePrem p <> brackets (prettyLNFact fa) <->+ (if mayLoop then comment_ "/* may loop */" else emptyDoc)+prettyGoal (PremDnKG p) = text "KD" <> parens (prettyNodePrem p)+prettyGoal (ImplG gf) = (text "Consequent" <>) $ nest 1 $ parens $ prettyGuarded gf prettyGoal (DisjG (Disj gfs)) = (text "Disj" <>) $ fsep $ punctuate (operator_ " |") (map (nest 1 . parens . prettyGuarded) gfs)@@ -700,6 +730,7 @@ prettyGoal (SplitG x) = text "splitEqs" <> parens (text $ show (succ x)) + -- Additional Show instances moved here due to TemplateHaskell splicing rules ----------------------------------------------------------------------------- @@ -716,8 +747,6 @@ { _crProtocol :: [RuleAC] -- all protocol rules , _crDestruct :: [RuleAC] -- destruction rules , _crConstruct :: [RuleAC] -- construction rules- , _crSpecial :: [RuleAC] -- rules that are handled by other means- -- than unification. } deriving( Eq, Ord, Show ) @@ -725,47 +754,49 @@ -- | The empty proof rule set. emptyClassifiedRules :: ClassifiedRules-emptyClassifiedRules = ClassifiedRules [] [] [] []---- | @joinNonSpecialRules rules@ computes the union of all non-special @rules@.-joinNonSpecialRules :: ClassifiedRules -> [RuleAC]-joinNonSpecialRules (ClassifiedRules a b c _) = a ++ b ++ c+emptyClassifiedRules = ClassifiedRules [] [] [] -- | @joinAllRules rules@ computes the union of all rules classified in -- @rules@. joinAllRules :: ClassifiedRules -> [RuleAC]-joinAllRules (ClassifiedRules a b c d) = a ++ b ++ c ++ d+joinAllRules (ClassifiedRules a b c) = a ++ b ++ c -- | Extract all non-silent rules. nonSilentRules :: ClassifiedRules -> [RuleAC]-nonSilentRules = filter (not . null . L.get rActs) . L.get crProtocol+nonSilentRules = filter (not . null . L.get rActs) . joinAllRules ------------------------------------------------------------------------------ -- Proof Context ------------------------------------------------------------------------------ --- | A goal for a big step case distinction.-data BigStepGoal = - PremiseBigStep LNFact- | MessageBigStep LNTerm- deriving( Eq, Ord, Show )- -- | A big-step case distinction. data CaseDistinction = CaseDistinction- { _cdGoal :: BigStepGoal -- start goal of case distinction+ { _cdGoal :: LNFact -- start goal of case distinction -- disjunction of named sequents with premise being solved; each name -- being the path of proof steps required to arrive at these cases , _cdCases :: Disj ([String], (NodeConc, Sequent)) } deriving( Eq, Ord, Show ) +-- | Whether we are checking for the existence of a trace satisfiying a the+-- current constraint system or whether we're checking that no traces+-- satisfies the current constraint system.+data SequentTraceQuantifier = ExistsSomeTrace | ExistsNoTrace+ deriving( Eq, Ord, Show )++data InductionHint = UseInduction | AvoidInduction+ deriving( Eq, Ord, Show )+ -- | A proof context contains the globally fresh facts, classified rewrite -- rules and the corresponding precomputed premise case distinction theorems. data ProofContext = ProofContext - { _pcSignature :: SignatureWithMaude- , _pcRules :: ClassifiedRules- , _pcCaseDists :: [CaseDistinction]+ { _pcSignature :: SignatureWithMaude+ , _pcRules :: ClassifiedRules+ , _pcCaseDistKind :: CaseDistKind+ , _pcCaseDists :: [CaseDistinction]+ , _pcUseInduction :: InductionHint+ , _pcTraceQuantifier :: SequentTraceQuantifier } deriving( Eq, Ord, Show ) @@ -784,20 +815,6 @@ <*> mapFrees f (L.get cdCases th) --- Instances---------------instance HasFrees BigStepGoal where- foldFrees f (PremiseBigStep fa) = foldFrees f fa- foldFrees f (MessageBigStep m) = foldFrees f m-- mapFrees f (PremiseBigStep fa) = PremiseBigStep <$> mapFrees f fa- mapFrees f (MessageBigStep m) = MessageBigStep <$> mapFrees f m--instance Apply BigStepGoal where- apply subst (PremiseBigStep fa) = PremiseBigStep (apply subst fa)- apply subst (MessageBigStep m) = MessageBigStep (apply subst m)- -- NFData --------- @@ -805,24 +822,22 @@ $( derive makeBinary ''Chain) $( derive makeBinary ''MsgEdge) $( derive makeBinary ''Edge)-$( derive makeBinary ''NodePrem)-$( derive makeBinary ''NodeConc) $( derive makeBinary ''EqStore) $( derive makeBinary ''CaseDistKind) $( derive makeBinary ''Sequent)-$( derive makeBinary ''BigStepGoal) $( derive makeBinary ''CaseDistinction) $( derive makeBinary ''ClassifiedRules)+$( derive makeBinary ''SequentTraceQuantifier)+$( derive makeBinary ''InductionHint) $( derive makeNFData ''Goal) $( derive makeNFData ''Chain) $( derive makeNFData ''MsgEdge) $( derive makeNFData ''Edge)-$( derive makeNFData ''NodePrem)-$( derive makeNFData ''NodeConc) $( derive makeNFData ''EqStore) $( derive makeNFData ''CaseDistKind) $( derive makeNFData ''Sequent)-$( derive makeNFData ''BigStepGoal) $( derive makeNFData ''CaseDistinction) $( derive makeNFData ''ClassifiedRules)+$( derive makeNFData ''SequentTraceQuantifier)+$( derive makeNFData ''InductionHint)
src/Theory/Rule.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TupleSections, TypeOperators, FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-}+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable, TupleSections, TypeOperators, FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt & Simon Meier -- License : GPL v3 (see LICENSE)@@ -11,6 +11,8 @@ module Theory.Rule ( -- * General Rules Rule(..)+ , PremIdx(..)+ , ConcIdx(..) -- ** Accessors , rInfo@@ -19,9 +21,10 @@ , rActs , rPrem , rConc- , rAct , lookupPrem , lookupConc+ , enumPrems+ , enumConcs -- ** Genereal protocol and intruder rules , RuleInfo(..)@@ -30,6 +33,12 @@ -- * Protocol Rule Information , ProtoRuleName(..) , ProtoRuleACInfo(..)+ , pracName+ , pracVariants+ , pracLoopBreakers+ , ProtoRuleACInstInfo(..)+ , praciName+ , praciLoopBreakers , RuleACConstrs -- * Intruder Rule Information@@ -44,6 +53,7 @@ -- ** Queries , HasRuleName(..)+ , isIntruderRule , isDestrRule , isConstrRule , isFreshRule@@ -51,7 +61,7 @@ , isISendRule , isCoerceRule , nfRule- , isTrivialProtoRuleAC+ , isTrivialProtoVariantAC -- ** Conversion , ruleACToIntrRuleAC@@ -72,6 +82,7 @@ , prettyIntrRuleAC , prettyIntrRuleACInfo , prettyRuleAC+ , prettyLoopBreakers , prettyRuleACInst -- * Convenience exports@@ -119,26 +130,38 @@ $(mkLabels [''Rule]) +-- | An index of a premise. The first premise has index '0'.+newtype PremIdx = PremIdx { getPremIdx :: Int }+ deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )++-- | An index of a conclusion. The first conclusion has index '0'.+newtype ConcIdx = ConcIdx { getConcIdx :: Int }+ deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )+ -- | @lookupPrem i ru@ returns the @i@-th premise of rule @ru@, if possible.-lookupPrem :: Int -> Rule i -> Maybe LNFact-lookupPrem i = (`atMay` i) . L.get rPrems+lookupPrem :: PremIdx -> Rule i -> Maybe LNFact+lookupPrem i = (`atMay` getPremIdx i) . L.get rPrems -- | @lookupConc i ru@ returns the @i@-th conclusion of rule @ru@, if possible.-lookupConc :: Int -> Rule i -> Maybe LNFact-lookupConc i = (`atMay` i) . L.get rConcs+lookupConc :: ConcIdx -> Rule i -> Maybe LNFact+lookupConc i = (`atMay` getConcIdx i) . L.get rConcs -- | @rPrem i@ is a lens for the @i@-th premise of a rule.-rPrem :: Int -> (Rule i :-> LNFact)-rPrem i = nthL i . rPrems+rPrem :: PremIdx -> (Rule i :-> LNFact)+rPrem i = nthL (getPremIdx i) . rPrems -- | @rConc i@ is a lens for the @i@-th conclusion of a rule.-rConc :: Int -> (Rule i :-> LNFact)-rConc i = nthL i . rConcs+rConc :: ConcIdx -> (Rule i :-> LNFact)+rConc i = nthL (getConcIdx i) . rConcs --- | @rAct i@ is a lens for the @i@-th action of a rule.-rAct :: Int -> (Rule i :-> LNFact)-rAct i = nthL i . rActs+-- | Enumerate all premises of a rule.+enumPrems :: Rule i -> [(PremIdx, LNFact)]+enumPrems = zip [(PremIdx 0)..] . L.get rPrems +-- | Enumerate all conclusions of a rule.+enumConcs :: Rule i -> [(ConcIdx, LNFact)]+enumConcs = zip [(ConcIdx 0)..] . L.get rConcs+ -- Instances ------------ @@ -200,10 +223,7 @@ -- | A name of a protocol rule is either one of the special reserved rules or -- some standard rule. data ProtoRuleName = - -- FIXME: Consider also moving them to intruder/model rules. FreshRule- | IRecvRule- | ISendRule | StandRule String -- ^ Some standard protocol rule deriving( Eq, Ord, Show, Data, Typeable ) @@ -212,12 +232,23 @@ -- instantiations of the free variables of the rule. The typing is interpreted -- modulo AC; i.e., its variants were also built. data ProtoRuleACInfo = ProtoRuleACInfo- { pracName :: ProtoRuleName- , pracVariants :: Disj (LNSubstVFresh)+ { _pracName :: ProtoRuleName+ , _pracVariants :: Disj (LNSubstVFresh)+ , _pracLoopBreakers :: [PremIdx] } deriving( Eq, Ord, Show ) +-- | Information for instances of protocol rules modulo AC.+data ProtoRuleACInstInfo = ProtoRuleACInstInfo+ { _praciName :: ProtoRuleName+ , _praciLoopBreakers :: [PremIdx]+ }+ deriving( Eq, Ord, Show ) ++$(mkLabels [''ProtoRuleACInfo, ''ProtoRuleACInstInfo])++ -- Instances ------------ @@ -228,21 +259,52 @@ foldFrees _ = const mempty mapFrees _ = pure +instance Apply PremIdx where+ apply _ = id +instance HasFrees PremIdx where+ foldFrees _ = const mempty+ mapFrees _ = pure++instance Apply ConcIdx where+ apply _ = id++instance HasFrees ConcIdx where+ foldFrees _ = const mempty+ mapFrees _ = pure+ instance HasFrees ProtoRuleACInfo where- foldFrees f (ProtoRuleACInfo na vari) =+ foldFrees f (ProtoRuleACInfo na vari breakers) = foldFrees f na `mappend` foldFrees f vari+ `mappend` foldFrees f breakers - mapFrees f (ProtoRuleACInfo na vari) = - ProtoRuleACInfo na <$> mapFrees f vari+ mapFrees f (ProtoRuleACInfo na vari breakers) = + ProtoRuleACInfo na <$> mapFrees f vari <*> mapFrees f breakers +instance Apply ProtoRuleACInstInfo where+ apply _ = id +instance HasFrees ProtoRuleACInstInfo where+ foldFrees f (ProtoRuleACInstInfo na breakers) =+ foldFrees f na `mappend` foldFrees f breakers+ + mapFrees f (ProtoRuleACInstInfo na breakers) = + ProtoRuleACInstInfo na <$> mapFrees f breakers++ ------------------------------------------------------------------------------ -- Intruder Rule Information ------------------------------------------------------------------------------ -- | An intruder rule modulo AC is described by its name.-data IntrRuleACInfo = IntrApp String | CoerceRule+data IntrRuleACInfo = + ConstrRule String+ | DestrRule String+ | CoerceRule+ | IRecvRule+ | ISendRule+ | PubConstrRule+ | FreshConstrRule deriving( Ord, Eq, Show, Data, Typeable ) -- | An intruder rule modulo AC.@@ -286,7 +348,7 @@ -- | A rule instance module AC is either a protocol rule or an intruder rule. -- The info identifies the corresponding rule modulo AC that the instance was -- derived from.-type RuleACInst = Rule (RuleInfo ProtoRuleName IntrRuleACInfo)+type RuleACInst = Rule (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) -- Accessing the rule name --------------------------@@ -299,32 +361,35 @@ ruleName = ProtoInfo . L.get rInfo instance HasRuleName RuleAC where- ruleName = ruleInfo (ProtoInfo . pracName) IntrInfo . L.get rInfo+ ruleName = ruleInfo (ProtoInfo . L.get pracName) IntrInfo . L.get rInfo instance HasRuleName ProtoRuleAC where- ruleName = ProtoInfo . pracName . L.get rInfo+ ruleName = ProtoInfo . L.get (pracName . rInfo) instance HasRuleName IntrRuleAC where ruleName = IntrInfo . L.get rInfo instance HasRuleName RuleACInst where- ruleName = L.get rInfo+ ruleName = ruleInfo (ProtoInfo . L.get praciName) IntrInfo . L.get rInfo -- Queries ---------- -- | True iff the rule is a destruction rule.-isDestrRule :: Rule r -> Bool-isDestrRule ru = case kFactView <$> L.get rConcs ru of- [Just (DnK, _, _)] -> True- _ -> False+isDestrRule :: HasRuleName r => r -> Bool+isDestrRule ru = case ruleName ru of+ IntrInfo (DestrRule _) -> True+ _ -> False -- | True iff the rule is a construction rule.-isConstrRule :: Rule r -> Bool-isConstrRule ru = case kFactView <$> L.get rConcs ru of- [Just (UpK, _, _)] -> True- _ -> False+isConstrRule :: HasRuleName r => r -> Bool+isConstrRule ru = case ruleName ru of+ IntrInfo (ConstrRule _) -> True+ IntrInfo FreshConstrRule -> True+ IntrInfo PubConstrRule -> True+ IntrInfo CoerceRule -> True+ _ -> False -- | True iff the rule is the special fresh rule. isFreshRule :: HasRuleName r => r -> Bool@@ -332,11 +397,11 @@ -- | True iff the rule is the special learn rule. isIRecvRule :: HasRuleName r => r -> Bool-isIRecvRule = (ProtoInfo IRecvRule ==) . ruleName+isIRecvRule = (IntrInfo IRecvRule ==) . ruleName -- | True iff the rule is the special knows rule. isISendRule :: HasRuleName r => r -> Bool-isISendRule = (ProtoInfo ISendRule ==) . ruleName+isISendRule = (IntrInfo ISendRule ==) . ruleName -- | True iff the rule is the special coerce rule. isCoerceRule :: HasRuleName r => r -> Bool@@ -350,29 +415,37 @@ nfFactList hnd xs = getAll $ foldMap (foldMap (All . (\t -> nf' t `runReader` hnd))) xs --- | True if the protocol rule has no variants.-isTrivialProtoRuleAC :: ProtoRuleAC -> Bool-isTrivialProtoRuleAC (Rule info _ _ _) =- pracVariants info == Disj [emptySubstVFresh]+-- | True iff the rule is an intruder rule+isIntruderRule :: HasRuleName r => r -> Bool+isIntruderRule ru =+ case ruleName ru of IntrInfo _ -> True; ProtoInfo _ -> False +-- | True if the protocol rule has only the trivial variant.+isTrivialProtoVariantAC :: ProtoRuleAC -> ProtoRuleE -> Bool+isTrivialProtoVariantAC (Rule info ps as cs) (Rule _ ps' as' cs') =+ L.get pracVariants info == Disj [emptySubstVFresh]+ && ps == ps' && as == as' && cs == cs' + -- Construction --------------- -type RuleACConstrs = Disj (LNSubstVFresh)+type RuleACConstrs = Disj LNSubstVFresh -- | Compute /some/ rule instance of a rule modulo AC. If the rule is a--- protocol rule, then the given typing and variants also need to handled.+-- protocol rule, then the given typing and variants also need to be handled. someRuleACInst :: MonadFresh m => RuleAC -> m (RuleACInst, Maybe RuleACConstrs) someRuleACInst = - (`evalBindT` noBindings) . fmap extractInsts . someInst+ fmap extractInsts . rename where extractInsts (Rule (ProtoInfo i) ps cs as) = - ( Rule (ProtoInfo (pracName i)) ps cs as- , Just (pracVariants i)+ ( Rule (ProtoInfo i') ps cs as+ , Just (L.get pracVariants i) )+ where+ i' = ProtoRuleACInstInfo (L.get pracName i) (L.get pracLoopBreakers i) extractInsts (Rule (IntrInfo i) ps cs as) = ( Rule (IntrInfo i) ps cs as, Nothing ) @@ -448,15 +521,19 @@ -- Pretty-Printing ------------------------------------------------------------------------------ +-- | Prefix the name if it is equal to a reserved name.+prefixIfReserved :: String -> String+prefixIfReserved n+ | n `elem` reserved = "_" ++ n+ | "_" `isPrefixOf` n = "_" ++ n+ | otherwise = n+ where+ reserved = ["Fresh", "irecv", "isend", "coerce", "fresh", "pub"]+ prettyProtoRuleName :: Document d => ProtoRuleName -> d prettyProtoRuleName rn = text $ case rn of- FreshRule -> "Fresh"- IRecvRule -> "IRecv"- ISendRule -> "ISend"- StandRule n - | n `elem` ["Fresh", "IRecv", "ISend"] -> "_" ++ n- | "_" `isPrefixOf` n -> "_" ++ n- | otherwise -> n+ FreshRule -> "Fresh"+ StandRule n -> prefixIfReserved n prettyRuleName :: (HighlightDocument d, HasRuleName (Rule i)) => Rule i -> d prettyRuleName = ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName@@ -467,8 +544,14 @@ render . ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName prettyIntrRuleACInfo :: Document d => IntrRuleACInfo -> d-prettyIntrRuleACInfo (IntrApp name) = text $ name-prettyIntrRuleACInfo CoerceRule = text "coerce"+prettyIntrRuleACInfo rn = text $ case rn of + IRecvRule -> "irecv"+ ISendRule -> "isend"+ CoerceRule -> "coerce"+ FreshConstrRule -> "fresh"+ PubConstrRule -> "pub"+ ConstrRule name -> prefixIfReserved ('c' : name)+ DestrRule name -> prefixIfReserved ('d' : name) prettyNamedRule :: (HighlightDocument d, HasRuleName (Rule i)) => d -- ^ Prefix.@@ -489,11 +572,20 @@ prettyProtoRuleACInfo :: HighlightDocument d => ProtoRuleACInfo -> d prettyProtoRuleACInfo i =- (ppVariants $ pracVariants i)+ (ppVariants $ L.get pracVariants i) $-$+ prettyLoopBreakers i where ppVariants (Disj [subst]) | subst == emptySubstVFresh = emptyDoc ppVariants substs = kwVariantsModulo "AC" $-$ prettyDisjLNSubstsVFresh substs +prettyLoopBreakers :: HighlightDocument d => ProtoRuleACInfo -> d+prettyLoopBreakers i = case breakers of+ [] -> emptyDoc+ [_] -> lineComment_ $ "loop breaker: " ++ show breakers+ _ -> lineComment_ $ "loop breakers: " ++ show breakers+ where+ breakers = getPremIdx <$> L.get pracLoopBreakers i+ prettyProtoRuleE :: HighlightDocument d => ProtoRuleE -> d prettyProtoRuleE = prettyNamedRule (kwRuleModulo "E") (const emptyDoc) @@ -517,11 +609,13 @@ $( derive makeBinary ''Rule) $( derive makeBinary ''ProtoRuleName) $( derive makeBinary ''ProtoRuleACInfo)+$( derive makeBinary ''ProtoRuleACInstInfo) $( derive makeBinary ''RuleInfo) $( derive makeBinary ''IntrRuleACInfo) $( derive makeNFData ''Rule) $( derive makeNFData ''ProtoRuleName) $( derive makeNFData ''ProtoRuleACInfo)+$( derive makeNFData ''ProtoRuleACInstInfo) $( derive makeNFData ''RuleInfo) $( derive makeNFData ''IntrRuleACInfo)
+ src/Theory/RuleSet.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Copyright : (c) 2012 Simon Meier+-- License : GPL v3 (see LICENSE)+-- +-- Maintainer : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Computations over sets of rewriting rules.+module Theory.RuleSet (++ -- * Computing loop breakers for solving premises+ useAutoLoopBreakersAC+ ) where++import Control.Applicative+import Control.Monad.Fresh+import Control.Monad.Reader++import Data.DAG.Simple++import Theory.Rule+++-- | An over-approximation of the dependency of solving premises. An element+-- @((fromRu, fromPrem), (toRu, toPrem))@ denotes that solving the premise+-- @(fromRu,fromPrem)@ might lead to a case where the premise @(toRu, toPrem)@+-- is open.+premSolvingRelAC :: (a -> [(PremIdx, LNFact)]) -- ^ Enumerate premises+ -> (a -> [(ConcIdx, LNFact)]) -- ^ Enumerate conclusions+ -> (a -> [LNSubstVFresh]) -- ^ Enumerate variants+ -> [a] -- ^ Base carrier+ -> WithMaude (Relation (a, PremIdx))+premSolvingRelAC ePrems eConcs eVariants rules = reader $ \hnd -> do+ (toRu, from) <- dataflowRelAC hnd+ (toPrem, _) <- ePrems toRu+ return (from, (toRu, toPrem))+ where+ -- An over-approxmiation of the dataflow relation. An element @(fromRu,+ -- (toRu, toPrem))@ denotes that there is a conclusion of @fromRu@+ -- unifying with the premise @(toRu, toPrem)@.+ dataflowRelAC hnd = do+ ruFrom <- rules+ ruTo <- rules+ (premIdx, premFa0) <- ePrems ruTo+ guard $ or $ do+ premFa <- instances ruTo premFa0+ concFa <- instances ruFrom =<< (snd <$> eConcs ruFrom)+ let concFaFresh = rename concFa `evalFresh` avoid premFa+ return $ (`runReader` hnd) (unifiableLNFacts concFaFresh premFa)+ return (ruFrom, (ruTo, premIdx))++ instances ru fa = do+ subst <- eVariants ru+ return (apply (subst `freshToFreeAvoiding` fa) fa)+++-- | Replace all loop-breaker information with loop-breakers computed+-- automatically from the dataflow relation 'dataflowRelAC'.+useAutoLoopBreakersAC + :: Ord a+ => (a -> [(PremIdx, LNFact)]) -- ^ Enumerate premises+ -> (a -> [(ConcIdx, LNFact)]) -- ^ Enumerate conclusions+ -> (a -> [LNSubstVFresh]) -- ^ Enumerate variants+ -> ([PremIdx] -> a -> a) -- ^ Add annotation+ -> [a] -- ^ Original rules+ -> WithMaude ([a], Relation (a, PremIdx), [(a, PremIdx)])+ -- ^ Annotated rules and the premise solving relation+useAutoLoopBreakersAC ePrems eConcs eVariants addAnn rules =+ reader $ \hnd ->+ let solveRel = (`runReader` hnd) $+ premSolvingRelAC ePrems eConcs eVariants rules+ breakers = dfsLoopBreakers $ solveRel+ in ( do ru <- rules+ return (addAnn [ u | (ru', u) <- breakers, ru == ru' ] ru)+ , solveRel+ , breakers+ )+
src/Theory/RuleVariants.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, StandaloneDeriving, TypeSynonymInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances, ViewPatterns, ScopedTypeVariables #-} -- | -- Copyright : (c) 2010-2012 Benedikt Schmidt -- License : GPL v3 (see LICENSE)@@ -19,10 +20,12 @@ import Control.Monad.Reader import Control.Monad.Bind+import qualified Control.Monad.Trans.PreciseFresh as Precise import Control.Applicative import qualified Data.Map as M import Data.Traversable (traverse)+import qualified Data.Set as S import Debug.Trace.Ignore @@ -38,14 +41,14 @@ variantsProtoRule :: MaudeHandle -> ProtoRuleE -> ProtoRuleAC variantsProtoRule hnd ru@(Rule ri prems0 concs0 acts0) = -- rename rule to decrease variable indices- (`evalFresh` nothingUsed) . rename $ convertRule `evalFreshAvoiding` ru+ (`Precise.evalFresh` Precise.nothingUsed) . renamePrecise $ convertRule `evalFreshAvoiding` ru where convertRule = do (abstrPsCsAs, bindings) <- abstrRule let eqsAbstr = map swap (M.toList bindings) abstractedTerms = map snd eqsAbstr abstractionSubst = substFromList eqsAbstr- variantSubsts = computeVariants (listToTerm abstractedTerms) `runReader` hnd+ variantSubsts = computeVariants (fAppList abstractedTerms) `runReader` hnd substs = [ restrictVFresh (frees abstrPsCsAs) $ removeRenamings $ ((`runReader` hnd) . normSubstVFresh') $ composeVFresh vsubst abstractionSubst@@ -55,7 +58,7 @@ [] -> error $ "variantsProtoRule: rule has no variants `"++show ru++"'" _ -> do -- x <- return (emptySubst, Just substs) -- - x <- simpDisjunction hnd (Disj substs)+ x <- simpDisjunction hnd (const False) (Disj substs) case trace (show ("SIMP",abstractedTerms, "abstr", abstrPsCsAs, "substs", substs,@@ -72,13 +75,19 @@ (,,) <$> mapM abstrFact prems0 <*> mapM abstrFact concs0 <*> mapM abstrFact acts0++ irreducible = irreducibleFunctionSymbols (mhMaudeSig hnd) abstrFact = traverse abstrTerm- abstrTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t)- where getHint (Lit (Var v)) = lvarName v- getHint _ = "z"+ abstrTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =+ fAppNonAC o <$> mapM abstrTerm args+ abstrTerm t = do+ at :: LNTerm <- varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t)+ return at+ where getHint (viewTerm -> Lit (Var v)) = lvarName v+ getHint _ = "z" makeRule (ps, cs, as) subst freshSubsts0 =- Rule (ProtoRuleACInfo ri (Disj freshSubsts)) prems concs acts+ Rule (ProtoRuleACInfo ri (Disj freshSubsts) []) prems concs acts where prems = apply subst ps concs = apply subst cs acts = apply subst as
src/Theory/Signature.hs view
@@ -43,7 +43,7 @@ import Theory.Pretty import Theory.Fact-import Term.Maude.Types+import Term.Maude.Signature import Data.Binary @@ -76,7 +76,7 @@ -- | The empty pure signature. emptySignaturePure :: SignaturePure-emptySignaturePure = Signature S.empty emptyMaudeSig+emptySignaturePure = Signature S.empty minimalMaudeSig -- Instances ------------
src/Theory/Wellformedness.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ViewPatterns #-} -- | -- Copyright : (c) 2010-2012 Simon Meier & Benedikt Schmidt -- License : GPL v3 (see LICENSE)@@ -13,19 +14,33 @@ -- -- [protocol rules] ----- 1. all facts are used with the same arity.+-- 1. no fresh names in rule. (protocol cond. 1)+-- ==> freshNamesReport ----- 2. fr, in, and out, facts are used with arity 1.+-- 2. no Out or K facts in premises. (protocol cond. 2)+-- ==> factReports ----- 3. fr facts are used with a variable of sort msg or sort fresh+-- 3. no Fr, In, or K facts in conclusions. (protocol cond. 3)+-- ==> factReports ----- 5. fresh facts of the same rule contain different variables. [TODO]+-- 4. vars(rhs) subset of vars(lhs) u V_Pub+-- ==> multRestrictedReport ----- 4. no fr, or in facts in conclusions.+-- 5. lhs does not contain reducible function symbols (*-restricted (a))+-- ==> multRestrictedReport ----- 5. no out facts in premises.+-- 6. rhs does not contain * (*-restricted (b))+-- ==> multRestrictedReport ----- 6. no protocol fact uses a reserved name => +-- 7. all facts are used with the same arity.+--+-- 8. fr, in, and out, facts are used with arity 1.+--+-- 9. fr facts are used with a variable of sort msg or sort fresh+--+-- 10. fresh facts of the same rule contain different variables. [TODO]+--+-- 11. no protocol fact uses a reserved name => -- [TODO] change parser to ensure this and pretty printer to show this. -- -- [security properties]@@ -57,9 +72,13 @@ import qualified Data.Set as S import Control.Basics import Control.Category+import Data.Traversable hiding (mapM) +import Control.Monad.Bind++import Term.Maude.Signature import Extension.Prelude-import Text.Isar+import Text.PrettyPrint.Class import Theory ------------------------------------------------------------------------------@@ -97,10 +116,14 @@ lowerCase :: String -> String lowerCase = map toLower --- | Pretty-print a comman, separated list of 'LVar's.+-- | Pretty-print a comma, separated list of 'LVar's. prettyVarList :: Document d => [LVar] -> d prettyVarList = fsep . punctuate comma . map prettyLVar +-- | Pretty-print a comma, separated list of 'LNTerms's.+prettyLNTermList :: Document d => [LNTerm] -> d+prettyLNTermList = fsep . punctuate comma . map prettyLNTerm+ -- | Wrap strings at word boundaries. wrappedText :: Document d => String -> d wrappedText = fsep . map text . words@@ -210,9 +233,9 @@ do ruleFacts <$> get thyCache thy <|> do RuleItem ru <- get thyItems thy return $ ruleFacts ru- <|> do LemmaItem (Lemma name fmE _ _ _) <- get thyItems thy- return $ (,) ("lemma " ++ quote name) $ do- fa <- formulaFacts fmE+ <|> do LemmaItem l <- get thyItems thy+ return $ (,) ("lemma " ++ quote (get lName l)) $ do+ fa <- formulaFacts (get lFormulaE l) return $ (text (show fa), factInfo fa) <|> do return $ (,) "unique_insts declaration" $ do tag <- S.toList $ get (sigpUniqueInsts . thySignature) thy @@ -276,7 +299,7 @@ ": " ++ showInfo info) $-$ nest 2 ppFa where- showInfo (tag, k, mult) = show $ (showFactTag tag, k, mult)+ showInfo (tag, k, multipl) = show $ (showFactTag tag, k, multipl) theoryFacts' = [ (ru, fa) | (ru, fas) <- theoryFacts, fa <- fas ] factIdentifier (_, (_, (tag, _, _))) = map toLower $ showFactTag tag @@ -284,14 +307,15 @@ -- Check that every fact referenced in a formula is present as an action -- of a protocol rule. We have to add the linear "K/1" fact, as the -- WF-check cannot rely on a loaded intruder theory.- ruleActions = S.fromList $ ((factInfo (kLogFact undefined)) :) $- do RuleItem ru <- get thyItems thy- factInfo <$> get rActs ru+ ruleActions = S.fromList $ map factInfo $ + kLogFact undefined : dedLogFact undefined :+ (do RuleItem ru <- get thyItems thy; get rActs ru) inexistentActions = do- LemmaItem (Lemma name fmE _ _ _) <- get thyItems thy- fa <- sortednub $ formulaFacts fmE+ LemmaItem l <- get thyItems thy+ fa <- sortednub $ formulaFacts (get lFormulaE l) let info = factInfo fa+ name = get lName l if info `S.member` ruleActions then [] else return $ (,) "lemma actions" $@@ -335,8 +359,9 @@ -- of facts, term, and atom constructors explicit. formulaReports :: OpenTheory -> WfErrorReport formulaReports thy = do- LemmaItem (Lemma name fmE _ _ _) <- get thyItems thy- let header = "lemma " ++ quote name + LemmaItem l <- get thyItems thy+ let header = "lemma " ++ quote (get lName l)+ fmE = get lFormulaE l msum [ ((,) "quantifier sorts") <$> checkQuantifiers header fmE , ((,) "formula terms") <$> checkTerms header fmE , ((,) "guardedness") <$> checkGuarded header fmE @@ -368,9 +393,9 @@ \ this is unambiguous" where offenders = filter (not . allowed) $ formulaTerms fm- allowed (Lit (Var (Bound _))) = True- allowed (Lit (Con (Name PubName _))) = True- allowed _ = False+ allowed (viewTerm -> Lit (Var (Bound _))) = True+ allowed (viewTerm -> Lit (Con (Name PubName _))) = True+ allowed _ = False -- check that the formula can be converted to a guarded formula checkGuarded header fm = case fromFormulaNegate fm of@@ -410,6 +435,73 @@ thyProtoRules thy -} ++-- | Check that all rules are multipliation restricted. Compared+-- to the definition in the paper we are slightly more lenient.+-- We also accept a rule that is an instance of a multiplication+-- restricted rule.+-- 1. Consistently abstract terms with outermost reducible function symbols+-- occuring in lhs with fresh variables in rule.+-- 2. check vars(rhs) subset of vars(lhs) u V_Pub for abstracted rule for abstracted variables.+-- 3. check that * does not occur in rhs of abstracted rule.+multRestrictedReport :: OpenTheory -> WfErrorReport+multRestrictedReport thy = do+ ru <- theoryRules thy+ (,) "multiplication restriction of rules" <$>+ case restrictedFailures ru of+ ([],[]) -> []+ (mults, unbounds) ->+ return $+ (text "The following rule is not multiplication restricted:")+ $-$ (nest 2 (prettyProtoRuleE ru))+ $-$ (text "")+ $-$ (text "After replacing reducible function symbols in lhs with variables:")+ $-$ (nest 2 $ prettyProtoRuleE (abstractRule ru))+ $-$ (text "")+ $-$ (if null mults then mempty+ else nest 2 $ (text "Terms with multiplication: ") <-> (prettyLNTermList mults))+ $-$ (if null unbounds then mempty+ else nest 2 $ (text "Variables that occur only in rhs: ") <-> (prettyVarList unbounds))+ where+ abstractRule ru@(Rule i lhs acts rhs) =+ (`evalFreshAvoiding` ru) . (`evalBindT` noBindings) $ do+ Rule i <$> mapM (traverse abstractTerm) lhs+ <*> mapM (traverse replaceAbstracted) acts+ <*> mapM (traverse replaceAbstracted) rhs++ abstractTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =+ fAppNonAC o <$> mapM abstractTerm args+ abstractTerm (viewTerm -> Lit l) = return $ lit l+ abstractTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t "x"++ replaceAbstracted t = do+ b <- lookupBinding t+ case b of+ Just v -> return $ varTerm v+ Nothing ->+ case viewTerm t of+ FApp o args ->+ fApp o <$> mapM replaceAbstracted args+ Lit l -> return $ lit l++ restrictedFailures ru = (mults, unbound ruAbstr \\ unbound ru)+ where+ ruAbstr = abstractRule ru++ mults = [ mt | Fact _ ts <- get rConcs ru, t <- ts, mt <- multTerms t ]++ multTerms t@(viewTerm -> FApp (AC Mult) _) = [t]+ multTerms (viewTerm -> FApp _ as) = concatMap multTerms as+ multTerms _ = []++ unbound ru = [v | v <- frees (get rConcs ru) \\ frees (get rPrems ru)+ , lvarSort v /= LSortPub ]+++ irreducible = irreducibleFunctionSymbols $ get (sigpMaudeSig . thySignature) thy+++ -- | All 2-multicombinations of a list. -- multicombine2 :: [a] -> [(a,a)] -- multicombine2 xs0 = do (x,xs) <- zip xs0 $ tails xs0; (,) x <$> xs@@ -432,6 +524,7 @@ , factReports , formulaReports , uniqueInstsReport+ , multRestrictedReport ] -- | Adds a note to the end of the theory, if it is not well-formed.
src/Web/Dispatch.hs view
@@ -26,7 +26,7 @@ import Web.Settings import Yesod.Core-import Yesod.Helpers.Static+import Yesod.Static import Network.Wai import qualified Data.Map as M@@ -47,6 +47,7 @@ import System.Directory -- | Create YesodDispatch instance for the interface.+-- mkYesodDispatch "WebUI" resourcesWebUI mkYesodDispatch "WebUI" resourcesWebUI -- | Static route for favicon file.@@ -55,34 +56,36 @@ -- | Favicon handler function (favicon.ico). getFaviconR :: Handler ()-getFaviconR = redirect RedirectPermanent (StaticR faviconRoute)+getFaviconR = redirect (StaticR faviconRoute) -- | Robots file handler function (robots.txt). getRobotsR :: Handler RepPlain getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: B.ByteString) -- | Initialization function for the web application.-withWebUI :: FilePath -- ^ Working directory.+withWebUI :: String -- ^ Message to output once the sever is ready.+ -> FilePath -- ^ Working directory. -> Bool -- ^ Load last proof state if present -> Bool -- ^ Automatically save proof state -> (FilePath -> IO ClosedTheory) -- ^ Theory loader (from file). -> (String -> IO ClosedTheory) -- ^ Theory loader (from string). -> (OpenTheory -> IO ClosedTheory) -- ^ Theory closer. -> Bool -- ^ Show debugging messages?- -> Maybe FilePath -- ^ Path to static content directory+ -> FilePath -- ^ Path to static content directory -> (Application -> IO b) -- ^ Function to execute -> IO b-withWebUI thDir loadState autosave thLoader thParser thCloser debug' stPath f = do+withWebUI readyMsg thDir loadState autosave thLoader thParser thCloser debug' stPath f = do thy <- getTheos thrVar <- newMVar M.empty thyVar <- newMVar thy+ st <- static stPath when autosave $ createDirectoryIfMissing False autosaveDir (`E.finally` shutdownThreads thrVar) $ f =<< toWaiApp WebUI { workDir = thDir , parseThy = liftIO . thParser , closeThy = thCloser- , getStatic = static $ fromMaybe defaultStaticDir stPath+ , getStatic = st , theoryVar = thyVar , threadVar = thrVar , autosaveProofstate = autosave@@ -104,7 +107,7 @@ _ -> return Nothing return $ M.fromList $ catMaybes thys - else loadTheories thDir thLoader+ else loadTheories readyMsg thDir thLoader shutdownThreads thrVar = do m <- modifyMVar thrVar $ \m -> return (M.empty, m)@@ -115,13 +118,12 @@ -- | Load theories from the current directory, generate map.-loadTheories :: FilePath -> (FilePath -> IO ClosedTheory) -> IO TheoryMap-loadTheories thDir thLoader = do+loadTheories :: String -> FilePath -> (FilePath -> IO ClosedTheory) -> IO TheoryMap+loadTheories readyMsg thDir thLoader = do mkImageDir thPaths <- filter (".spthy" `isSuffixOf`) <$> getDirectoryContents thDir theories <- catMaybes <$> mapM loadThy (zip [1..] (map (thDir </>) thPaths))- putStrLn ""- putStrLn "Finished loading theories ... server ready."+ putStrLn readyMsg return $ M.fromList theories where -- Create image directory
src/Web/Hamlet.hs view
@@ -14,7 +14,10 @@ PatternGuards, FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Web.Hamlet where+module Web.Hamlet (+ rootTpl+ , overviewTpl + ) where import Theory import Web.Types@@ -23,17 +26,19 @@ import Text.PrettyPrint.Html import Yesod.Core-import Yesod.Form-import Text.Hamlet+-- import Yesod.Form+-- import Text.Hamlet +import Control.Monad.IO.Class (liftIO) import Data.Ord import Data.List import Data.Time.Format import Data.Version (showVersion) import qualified Data.Map as M-import qualified Data.Text as T+-- import qualified Data.Text as T+import Text.Blaze.Html5 (preEscapedString) -import Control.Monad.RWS (runRWST)+-- import Control.Monad.RWS (runRWST) import qualified Control.Exception as E import System.Locale @@ -42,9 +47,9 @@ -- Quasi-quotation syntax changed from GHC 6 to 7, -- so we need this switch in order to support both #if __GLASGOW_HASKELL__ >= 700-#define HAMLET hamlet+#define HAMLET whamlet #else-#define HAMLET $hamlet+#define HAMLET $whamlet #endif --@@ -52,7 +57,7 @@ -- -- | Wrapper for @HtmlDoc@ values.-wrapHtmlDoc :: HamletValue h => HtmlDoc Doc -> h+wrapHtmlDoc :: HtmlDoc Doc -> Widget wrapHtmlDoc doc | null res = exceptionTpl err | otherwise = [HAMLET|#{preEscapedString res}|]@@ -61,10 +66,12 @@ err = "Trying to render document yielded empty string. This is a bug." -- | Run a ThHtml value, catch exceptions.-wrapThHtml :: HamletValue h => HtmlDoc Doc -> IO h-wrapThHtml th = E.catch (return $ wrapHtmlDoc th) handleEx+wrapThHtml :: HtmlDoc Doc -> IO Widget+wrapThHtml th = + E.catch (return $ wrapHtmlDoc th) handleEx where- handleEx :: HamletValue h => E.SomeException -> IO h+ -- handleEx :: HamletValue h => E.SomeException -> IO h+ handleEx :: E.SomeException -> IO Widget handleEx e = do putStrLn "----------------" putStrLn "Caught exception"@@ -77,49 +84,58 @@ -- -- | Exception/error template.-exceptionTpl :: HamletValue h => String -> h+exceptionTpl :: String -> Widget exceptionTpl err = [HAMLET| <h1>Caught exception! \#{err} |] +{- -- | Simple template for serving sites which are loaded through -- AJAX instead of a normal request (no html/head/body tags). -- -- Note: Don't use ajaxLayout and defaultLayout together, use -- only one or the other.-ajaxLayout :: Monad m => GenericWidget m () -> GenericHandler m RepHtml-ajaxLayout w = do- (body, _, _) <- runRWST (unGWidget $ extractBody w) () 0- hamletToRepHtml [HAMLET|^{body}|]+-- ajaxLayout :: Monad m => GenericWidget m () -> GenericHandler m RepHtml+ajaxLayout w = error "ajaxLayout" $ fmap fst $ unGWidget w -- do+ -- (body, _, _) <- runRWST (unGWidget $ extractBody w) () 0+ -- (body, _, _) <- unGWidget $ w -- () 0+ -- hamletToRepHtml [HAMLET|^{body}|]+-} -- | Template for root/welcome page.-rootTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute, h ~ Widget ())- => TheoryMap -- ^ Map of loaded theories- -> Widget () -- ^ Form widget (for loading new theories)- -> Enctype -- ^ Form encoding type (for form)- -> Html -- ^ Nonce field (for form)- -> h-rootTpl theories form enctype nonce = [HAMLET|+rootTpl :: TheoryMap -- ^ Map of loaded theories+ -> Widget+-- rootTpl theories form enctype nonce = [whamlet|+rootTpl theories = [whamlet|+ <div class="ui-layout-container">+ <div class="ui-layout-north">+ <div class="ui-layout-pane">+ <div class="layout-pane-north">+ <div class="ui-layout-pane-north">+ <div id="introbar">+ <div id="header-info">+ Running+ \ <a href=@{RootR}><span class="tamarin">Tamarin</span></a>+ \ #{showVersion version} \^{introTpl}- <h2>Currently loaded theories- <p- Here is a list of the theories that are currently loaded.<br/>- \^{theoriesTpl theories}- <h2>Loading a new theory- <p- You can load a new theory file from disk in order to work with it.- <form class=root-form action=@{RootR} method=POST enctype=#{enctype}>- ^{form}- <div .submit-form>- ^{addHtml nonce}- <input type=submit value="Load new theory">- <p>Note: You can save a theory by downloading the source. + <div class="intropage">+ <p>+ \^{theoriesTpl theories}+ <h2>Loading a new theory+ <p+ You can load a new theory file from disk in order to work with it.+ <form class=root-form enctype="multipart/form-data" action=@{RootR} method=POST>+ Filename:+ <input type=file name="uploadedTheory">+ <div .submit-form>+ <input type=submit value="Load new theory">+ <p>Note: You can save a theory by downloading the source. |] -- | Template for listing theories.-theoriesTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => TheoryMap -> h-theoriesTpl thmap = [HAMLET|+theoriesTpl :: TheoryMap -> Widget+theoriesTpl thmap = [whamlet| $if M.null thmap <strong>No theories loaded!</strong> $else@@ -148,19 +164,17 @@ | otherwise = ntail i xs -- | Template for single line in table on root page.-theoryTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute)- => (TheoryIdx, TheoryInfo) -> h+theoryTpl :: (TheoryIdx, TheoryInfo) -> Widget theoryTpl th = [HAMLET| <tr> <td>- <a href=@{OverviewR (fst th)}>+ <a href=@{OverviewR (fst th) TheoryHelp}> \#{get thyName $ tiTheory $ snd th}- </a> <td>#{formatTime defaultTimeLocale "%T" $ tiTime $ snd th} $if tiPrimary (snd th) <td>Original $else- <td><em>Modified</em>+ <td><em>Modified <td>#{origin th} |] where@@ -170,7 +184,8 @@ Interactive -> "(interactively created)" -- | Template for listing threads.-threadsTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => [T.Text] -> h+-- threadsTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => [T.Text] -> h+{- threadsTpl threads = [HAMLET| <h2>Threads <p>@@ -189,16 +204,16 @@ <td>#{th} <td><a href="@{KillThreadR}?path=#{th}">Kill</a> |]+-} -- | Template for header frame (various information)-headerTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute)- => TheoryInfo -- ^ Theory information- -> h+headerTpl :: TheoryInfo -> Widget headerTpl info = [HAMLET|- <div #header-info>- Running \- <a href="http://www.infsec.ethz.ch/research/software#TAMARIN">tamarin prover</a>- \ #{showVersion version}+ <div class="layout-pane-north">+ <div #header-info>+ Running+ \ <a href=@{RootR}><span class="tamarin">Tamarin</span></a>+ \ #{showVersion version} <div #header-links> <a class=plain-link href=@{RootR}>Index</a> <a class=plain-link href=@{DownloadTheoryR idx filename}>Download</a>@@ -206,16 +221,17 @@ <li><a href="#">Actions</a> <ul> <li><a target=_blank href=@{TheorySourceR idx}>Show source</a>- <li><a href=@{TheoryVariantsR idx}>Show variants</a>- <li><a class=edit-link href=@{EditTheoryR idx}>Edit theory</a>- <li><a class=edit-link href=@{EditPathR idx (TheoryLemma "")}>Add lemma</a> <li><a href="#">Options</a> <ul> <li><a id=graph-toggle href="#">Compact graphs</a> <li><a id=seqnt-toggle href="#">Compress sequents</a>- <li><a id=debug-toggle href="#">Debug pane</a> |] where+ -- <li><a id=debug-toggle href="#">Debug pane</a>+ -- <li><a href=@{TheoryVariantsR idx}>Show variants</a>+ -- <li><a class=edit-link href=@{EditTheoryR idx}>Edit theory</a>+ -- <li><a class=edit-link href=@{EditPathR idx (TheoryLemma "")}>Add lemma</a>+ -- idx = tiIndex info filename = get thyName (tiTheory info) ++ ".spthy" @@ -229,24 +245,22 @@ -} -- | Template for proof state (tree) frame.-proofStateTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute)- => TheoryInfo -- ^ Theory information- -> IO h-proofStateTpl = wrapThHtml . theoryIndex . tiTheory+proofStateTpl :: RenderUrl -> TheoryInfo -> IO Widget+proofStateTpl renderUrl ti = wrapThHtml $ theoryIndex renderUrl (tiIndex ti) (tiTheory ti) -- | Framing/UI-layout template (based on JavaScript/JQuery)-overviewTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute)- => TheoryInfo -- ^ Theory information+overviewTpl :: RenderUrl+ -> TheoryInfo -- ^ Theory information -> TheoryPath -- ^ Theory path to load into main- -> IO h-overviewTpl info path = do- proofState <- proofStateTpl info- mainView <- pathTpl info path+ -> IO Widget+overviewTpl renderUrl info path = do+ proofState <- proofStateTpl renderUrl info+ mainView <- pathTpl renderUrl info path return [HAMLET| <div .ui-layout-north> ^{headerTpl info} <div .ui-layout-west>- <h1 .pane-head> Proof scripts+ <h1 .pane-head>Proof scripts <div #proof-wrapper .scroll-wrapper> <div #proof .monospace> ^{proofState}@@ -255,84 +269,106 @@ <div #debug-wrapper .scroll-wrapper> <div #ui-debug-display> <div .ui-layout-center>- <h1 #main-title .pane-head> Visualization display+ <h1 #main-title .pane-head>Visualization display <div #main-wrapper .scroll-wrapper tabindex=0> <div #ui-main-display> \^{mainView} |] -- | Theory path, displayed when loading main screen for first time.-pathTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute)- => TheoryInfo -- ^ The theory+pathTpl :: RenderUrl+ -> TheoryInfo -- ^ The theory -> TheoryPath -- ^ Path to display on load- -> IO h-pathTpl info TheoryMain = return [HAMLET|- <h2>Welcome!</h2><br/>+ -> IO Widget+pathTpl _ info TheoryHelp = return [whamlet| <h3>Theory information</h3> <ul <li>Theory: #{get thyName $ tiTheory info} <li>Loaded at #{formatTime defaultTimeLocale "%T" $ tiTime info} <li>Origin: #{show $ tiOrigin info}- <h3>Quick introduction</h3>- <p>- <em>Left pane:</em> Proof scripts display. You \- can select proof states and examine them further \- by clicking on them!- <p>- <em>Center pane:</em> Visualization and \- information display relating to the currently \- selected item.- <p>- <em>Keyboard shortcuts:</em> The interactive interface supports \- multiple keyboard shortcuts for convenience. - <ul>- <li>- Keys <span class=keys>j and k</span>: Jump to the next/previous \- proof path within the currently focused lemma.- <li>- Keys <span class=keys>J and K</span>: Jump to the next/previous \- open goal within the currently focused lemma, or to the \- next/previous lemma if there are no more open goals in the current \- lemma.- <li>- Keys <span class=keys>1 to 9</span>: Apply the proof method with \- the given number as shown in the applicable proof method section \- in the main view.+ <div id="help">+ <h3>Quick introduction</h3>+ <noscript>+ <div class="warning">+ Warning: JavaScript must be enabled for the <span class="tamarin">Tamarin</span> prover GUI to function properly.+ <p>+ <em>Left pane: Proof scripts display.+ <ul>+ <li>+ When a theory is initially loaded, there will be a line at the end of each theorem \+ stating <tt>"by sorry // not yet proven"</tt>. Click on <tt>sorry</tt> to inspect the proof state.+ <li>+ Right-click to show further options, such as auto-prove.+ <li>+ Click on the icons to the right of a lemma name to reveal further options.+ <p>+ <em>Center pane: Visualization.+ <ul>+ <li>+ Visualization and information display relating to the currently \+ selected item.+ <p>+ <em>Keyboard shortcuts.+ <ul>+ <li>+ <span class="keys">j/k</span>: Jump to the next/previous \+ proof path within the currently focused lemma.+ <li>+ <span class="keys">J/K</span>: Jump to the next/previous \+ open goal within the currently focused lemma, or to the \+ next/previous lemma if there are no more open goals in the current \+ lemma.+ <li>+ <span class="keys">1-9</span>: Apply the proof method with \+ the given number as shown in the applicable proof method section \+ in the main view.+ <li>+ <span class="keys">a</span>: Apply the autoprove method to \+ the current goal. |]-pathTpl info path = wrapThHtml $ htmlThyPath (tiTheory info) path+pathTpl renderUrl info path = liftIO . wrapThHtml $ htmlThyPath renderUrl info path -- | Template for introduction.-introTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute) => h+introTpl :: Widget introTpl = [HAMLET|- <h1>Welcome!</h1>- <h2>About- <p>- You are running the\- <strong>- <a href="http://www.infsec.ethz.ch/research/software#TAMARIN">tamarin prover</a>- </strong>- \ version #{showVersion version} in interactive mode.<br>- \ © 2010 - 2012 \- <a href="https://www1.ethz.ch/infsec/people/benschmi">Benedikt Schmidt</a>- , <a href="http://people.inf.ethz.ch/meiersi">Simon Meier</a>- , <a href="https://cssx.ch">Cedric Staub</a>- , <a href="http://www.infsec.ethz.ch">Information Security Institute</a>- , <a href="http://www.ethz.ch">ETH Zurich</a>- <p>- This program comes with ABSOLUTELY NO WARRANTY. It is free software, and- \ you are welcome to redistribute it according to its- \ <a href="/static/LICENSE" type="text/plain">LICENSE</a>.+ <div id="logo">+ <p>+ <img src="/static/img/tamarin-logo-3-0-0.png">+ <noscript>+ <div class="warning">+ Warning: JavaScript must be enabled for the <span class="tamarin">Tamarin</span> prover GUI to function properly.+ <div class="intropage">+ <p>+ Authors:+ \ <a href="http://people.inf.ethz.ch/meiersi">Simon Meier</a>,+ \ <a href="https://www1.ethz.ch/infsec/people/benschmi">Benedikt Schmidt</a><br>+ Contributors:+ \ <a href="http://people.inf.ethz.ch/cremersc/index.html">Cas Cremers</a>,+ \ <a href="https://cssx.ch">Cedric Staub</a>+ <p>+ <span class="tamarin">Tamarin</span> was developed at the+ \ <a href="http://www.infsec.ethz.ch">Information Security Institute</a>,+ \ <a href="http://www.ethz.ch">ETH Zurich</a>.+ \ This program comes with ABSOLUTELY NO WARRANTY. It is free software, and+ \ you are welcome to redistribute it according to its+ \ <a href="/static/LICENSE" type="text/plain">LICENSE.</a>+ <p>+ More information about Tamarin and technical papers describing the underlying+ \ theory can be found on the+ \ <a href="http://www.infsec.ethz.ch/research/software#TAMARIN"><span class="tamarin">Tamarin</span>+ \ webpage</a>. |] +{- -- | Template for editing a theory.-formTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute, h ~ Widget ())- => WebUIRoute -- ^ Form action route- -> String -- ^ Submit button label- -> Widget () -- ^ Form widget- -> Enctype -- ^ Form encoding type- -> Html -- ^ Nonce field- -> h-formTpl action label form enctype nonce = [HAMLET|+-- formTpl :: (HamletValue h, HamletUrl h ~ WebUIRoute, h ~ Widget ())+-- => WebUIRoute -- ^ Form action route+-- -> String -- ^ Submit button label+-- -> Widget () -- ^ Form widget+-- -> Enctype -- ^ Form encoding type+-- -> Html -- ^ Nonce field+-- -> h+formTpl action label form enctype nonce = [whamlet| <form action=@{action} method=POST enctype=#{enctype}> ^{form} <div .submit-form>@@ -340,3 +376,4 @@ <input type=submit value=#{label}> <input type=button id=cancel-form value=Cancel> |]+-}
src/Web/Handler.hs view
@@ -1,7 +1,7 @@ {- | Module : Web.Handler Description : Application-specific handler functions.-Copyright : (c) 2011 Cedric Staub+Copyright : (c) 2011 Cedric Staub, 2012 Benedikt Schmidt License : GPL-3 Maintainer : Cedric Staub <cstaub@ethz.ch>@@ -10,7 +10,7 @@ -} {-# LANGUAGE- OverloadedStrings, QuasiQuotes, TypeFamilies, + OverloadedStrings, QuasiQuotes, TypeFamilies, FlexibleContexts, RankNTypes, TemplateHaskell, CPP #-} module Web.Handler@@ -21,7 +21,7 @@ , getTheoryMessageDeductionR , getTheoryVariantsR , getTheoryPathMR- , getTheoryPathDR+ -- , getTheoryPathDR , getTheoryGraphR , getAutoProverR , getDeleteStepR@@ -30,24 +30,27 @@ , getPrevTheoryPathR , getSaveTheoryR , getDownloadTheoryR- , getEditTheoryR- , postEditTheoryR- , getEditPathR- , postEditPathR+ -- , getEditTheoryR+ -- , postEditTheoryR+ -- , getEditPathR+ -- , postEditPathR , getUnloadTheoryR- , getThreadsR+ -- , getThreadsR ) where import Theory ( ClosedTheory,- lName, thyName, - lookupLemma, addLemma, removeLemma,+ thyName, + -- lName,+ -- lookupLemma, addLemma, + removeLemma, openTheory, mapProverProof, sorryProver, autoProver, cutOnAttackDFS,- prettyProof, prettyLemma, prettyClosedTheory, prettyOpenTheory + prettyClosedTheory, prettyOpenTheory + -- prettyProof, prettyLemma, prettyClosedTheory, prettyOpenTheory )-import Theory.Parser+-- import Theory.Parser import Theory.Proof.Sequent.Dot import Web.Types import Web.Hamlet@@ -58,14 +61,13 @@ import Yesod.Core import Yesod.Json()-import Yesod.Form-import Text.Hamlet+-- import Yesod.Form+-- import Text.Hamlet import Data.Maybe import Data.Aeson-import Data.Aeson.Encode (fromValue) import Data.Label-import Data.Traversable (traverse)+-- import Data.Traversable (traverse) import qualified Data.Map as M import qualified Data.Text as T@@ -74,14 +76,16 @@ import Data.Text.Encoding import qualified Blaze.ByteString.Builder as B import Network.HTTP.Types ( urlDecode )+import Text.Blaze.Html5 (toHtml) import Control.Monad import Control.Monad.IO.Class-import Control.Monad.IO.Control+-- import Control.Monad.IO.Control+import Control.Monad.Trans.Control import Control.Applicative import Control.Concurrent import Control.DeepSeq-import qualified Control.Exception.Control as E+import qualified Control.Exception.Lifted as E import Control.Exception.Base import qualified Control.Concurrent.Thread as Thread ( forkIO ) import Data.Time.LocalTime@@ -105,9 +109,9 @@ -- | Store theory map in file if option enabled. storeTheory :: WebUI- -> TheoryInfo- -> TheoryIdx- -> IO ()+ -> TheoryInfo+ -> TheoryIdx+ -> IO () storeTheory yesod thy idx = when (autosaveProofstate yesod) $ do let f = workDir yesod++"/"++autosaveSubdir++"/"++show idx++".img"@@ -115,19 +119,16 @@ renameFile (f++".tmp") f -- | Load a theory given an index.-getTheory :: MonadIO m- => TheoryIdx- -> GenericHandler m (Maybe TheoryInfo)+getTheory :: TheoryIdx -> Handler (Maybe TheoryInfo) getTheory idx = do yesod <- getYesod liftIO $ withMVar (theoryVar yesod) $ return . M.lookup idx -- | Store a theory, return index.-putTheory :: MonadIO m- => Maybe TheoryInfo -- ^ Index of parent theory- -> Maybe TheoryOrigin -- ^ Origin of this theory- -> ClosedTheory -- ^ The new closed theory- -> GenericHandler m TheoryIdx+putTheory :: Maybe TheoryInfo -- ^ Index of parent theory+ -> Maybe TheoryOrigin -- ^ Origin of this theory+ -> ClosedTheory -- ^ The new closed theory+ -> Handler TheoryIdx putTheory parent origin thy = do yesod <- getYesod liftIO $ modifyMVar (theoryVar yesod) $ \theories -> do@@ -141,7 +142,7 @@ return (M.insert idx newThy theories, idx) -- | Delete theory.-delTheory :: MonadIO m => TheoryIdx -> GenericHandler m ()+delTheory :: TheoryIdx -> Handler () delTheory idx = do yesod <- getYesod liftIO $ modifyMVar_ (theoryVar yesod) $ \theories -> do@@ -150,17 +151,16 @@ return theories' -- | Get a map of all stored theories.-getTheories :: MonadIO m => GenericHandler m TheoryMap+getTheories :: Handler TheoryMap getTheories = do yesod <- getYesod liftIO $ withMVar (theoryVar yesod) return -- | Modify a theory in the map of theories.-adjTheory :: MonadIO m- => TheoryIdx+adjTheory :: TheoryIdx -> (TheoryInfo -> TheoryInfo)- -> GenericHandler m ()+ -> Handler () adjTheory idx f = do yesod <- getYesod liftIO $ modifyMVar_ (theoryVar yesod) $ \theories ->@@ -177,10 +177,9 @@ | otherwise = id -- | Register a thread for killing.-putThread :: MonadControlIO m- => T.Text -- ^ Request path+putThread :: T.Text -- ^ Request path -> ThreadId -- ^ Thread ID- -> GenericHandler m ()+ -> Handler () putThread str tid = do yesod <- getYesod liftIO $ dtrace yesod msg $@@ -189,9 +188,8 @@ msg = "Registering thread: " ++ T.unpack str -- | Unregister a thread for killing.-delThread :: MonadControlIO m- => T.Text -- ^ Request path- -> GenericHandler m ()+delThread :: T.Text -- ^ Request path+ -> Handler () delThread str = do yesod <- getYesod liftIO $ dtrace yesod msg $@@ -199,10 +197,10 @@ where msg = "Deleting thread: " ++ T.unpack str + -- | Get a thread for the given request URL.-getThread :: MonadIO m- => T.Text -- ^ Request path- -> GenericHandler m (Maybe ThreadId)+getThread :: T.Text -- ^ Request path+ -> Handler (Maybe ThreadId) getThread str = do yesod <- getYesod liftIO $ dtrace yesod msg $@@ -210,31 +208,31 @@ where msg = "Retrieving thread id of: " ++ T.unpack str +{- -- | Get the map of all threads.-getThreads :: MonadIO m- => GenericHandler m [T.Text]+-- getThreads :: MonadIO m+-- => GenericHandler m [T.Text] getThreads = do yesod <- getYesod liftIO $ withMVar (threadVar yesod) (return . M.keys)-+-} ------------------------------------------------------------------------------ -- Helper functions ------------------------------------------------------------------------------ -- | Print exceptions, if they happen.-traceExceptions :: MonadControlIO m => String -> m a -> m a+traceExceptions :: MonadBaseControl IO m => String -> m a -> m a traceExceptions info = E.handle handler where- handler :: MonadControlIO m => E.SomeException -> m a+ handler :: MonadBaseControl IO m => E.SomeException -> m a handler e =- trace (info ++ ": exception `" ++ show e ++ "'") $ - liftIO $ E.throw e+ trace (info ++ ": exception `" ++ show e ++ "'") $ E.throwIO e -- | Helper functions for generating JSON reponses.-jsonResp :: Monad m => JsonResponse -> GenericHandler m RepJson-jsonResp = return . RepJson . toContent . fromValue . responseToJson+jsonResp :: JsonResponse -> GHandler m WebUI RepJson+jsonResp = return . RepJson . toContent . responseToJson responseToJson :: JsonResponse -> Value responseToJson = go@@ -251,9 +249,9 @@ contentToJson _ = error "Unsupported content format in json response!" -- | Fully evaluate a value in a thread that can be canceled.-evalInThread :: (NFData a, MonadControlIO m)+evalInThread :: NFData a => IO a- -> GenericHandler m (Either SomeException a)+ -> Handler (Either SomeException a) evalInThread io = do renderF <- getUrlRender maybeRoute <- getCurrentRoute@@ -271,49 +269,50 @@ -- | Evaluate a handler with a given theory specified by the index, -- return notFound if theory does not exist.-withTheory :: MonadIO m- => TheoryIdx- -> (TheoryInfo -> GenericHandler m a)- -> GenericHandler m a+withTheory :: TheoryIdx+ -> (TheoryInfo -> Handler a)+ -> Handler a withTheory idx handler = do maybeThy <- getTheory idx case maybeThy of Just ti -> handler ti Nothing -> notFound +{- -- | Run a form and provide a JSON response.-formHandler :: (HamletValue h, HamletUrl h ~ WebUIRoute, h ~ Widget ())- => T.Text -- ^ The form title- -> Form WebUI WebUI a -- ^ The formlet to run- -> (Widget () -> Enctype -> Html -> h) -- ^ Template to render form with- -> (a -> GenericHandler IO RepJson) -- ^ Function to call on success- -> Handler RepJson+-- formHandler :: (HamletValue h, HamletUrl h ~ WebUIRoute, h ~ Widget ())+-- => T.Text -- ^ The form title+-- -> Form WebUI WebUI a -- ^ The formlet to run+-- -> (Widget () -> Enctype -> Html -> h) -- ^ Template to render form with+-- -> (a -> GenericHandler IO RepJson) -- ^ Function to call on success+-- -> Handler RepJson formHandler title formlet template success = do- (result, widget, enctype, nonce) <- runFormPost formlet+ -- (result, widget, enctype, nonce) <- runFormPost formlet+ ((result, widget), enctype) <- runFormPost formlet case result of FormMissing -> do- RepHtml content <- ajaxLayout (template widget enctype nonce)+ RepHtml content <- ajaxLayout (template widget enctype) jsonResp $ JsonHtml title content FormFailure _ -> jsonResp $ JsonAlert "Missing fields in form. Please fill out all required fields."- FormSuccess ret -> liftIOHandler (success ret)+ FormSuccess ret -> lift (success ret)+-} -- | Modify a theory, redirect if successful.-modifyTheory :: (MonadControlIO m, Functor m)- => TheoryInfo -- ^ Theory to modify+modifyTheory :: TheoryInfo -- ^ Theory to modify -> (ClosedTheory -> IO (Maybe ClosedTheory)) -- ^ Function to apply+ -> (ClosedTheory -> TheoryPath) -- ^ Compute the new path -> JsonResponse -- ^ Response on failure- -> GenericHandler m Value-modifyTheory ti f errResponse = do- -- res <- evalInThread (liftIO $ f (tiTheory ti))+ -> Handler Value+modifyTheory ti f fpath errResponse = do res <- evalInThread (liftIO $ f (tiTheory ti)) case res of Left e -> return (excResponse e) Right Nothing -> return (responseToJson errResponse) Right (Just thy) -> do newThyIdx <- putTheory (Just ti) Nothing thy- newUrl <- getUrlRender <*> pure (OverviewR newThyIdx) + newUrl <- getUrlRender <*> pure (OverviewR newThyIdx (fpath thy)) return . responseToJson $ JsonRedirect newUrl where excResponse e = responseToJson@@ -326,44 +325,47 @@ -- | The root handler lists all theories by default, -- or load a new theory if the corresponding form was submitted. getRootR :: Handler RepHtml-getRootR = postRootR+getRootR = do+ theories <- getTheories+ defaultLayout $ do+ setTitle "Welcome to the Tamarin prover"+ addWidget (rootTpl theories) +data File = File T.Text+ deriving Show+ postRootR :: Handler RepHtml postRootR = do- (result, widget, enctype, nonce) <- runFormPost submitForm+ result <- lookupFile "uploadedTheory" case result of- FormMissing -> return ()- FormFailure errs -> do- mapM_ (liftIO . print) errs- setMessage "Loading failed."- FormSuccess fileinfo -> do+ Nothing ->+ setMessage "Post request failed."+ Just fileinfo -> do yesod <- getYesod- closedThy <- parseThy yesod (BS.unpack $ fileContent fileinfo)+ closedThy <- liftIO $ parseThy yesod (BS.unpack $ fileContent fileinfo) void $ putTheory Nothing (Just $ Upload $ T.unpack $ fileName fileinfo) closedThy setMessage "Loaded new theory!" theories <- getTheories defaultLayout $ do- setTitle "Welcome to the tamarin prover"- addWidget (rootTpl theories widget enctype nonce)- where- submitForm = fieldsToDivs $ fileField $ FormFieldSettings- "Select file:" "Select file" Nothing Nothing+ setTitle "Welcome to the Tamarin prover"+ addWidget (rootTpl theories) -- | Show overview over theory (framed layout).-getOverviewR :: TheoryIdx -> Handler RepHtml-getOverviewR idx = withTheory idx $ \ti -> defaultLayout $ do- overview <- liftIO $ overviewTpl ti TheoryMain- setTitle (toHtml $ "Theory: " ++ get thyName (tiTheory ti))- addWidget overview+getOverviewR :: TheoryIdx -> TheoryPath -> Handler RepHtml+getOverviewR idx path = withTheory idx $ \ti -> do+ renderF <- getUrlRender+ defaultLayout $ do+ overview <- liftIO $ overviewTpl renderF ti path+ setTitle (toHtml $ "Theory: " ++ get thyName (tiTheory ti))+ addWidget overview -- | Show source (pretty-printed open theory). getTheorySourceR :: TheoryIdx -> Handler RepPlain getTheorySourceR idx = withTheory idx $ \ti -> return $ RepPlain $ toContent $ prettyRender ti- where - -- prettyRender = render . prettyOpenTheory . openTheory . tiTheory+ where prettyRender = render . prettyClosedTheory . tiTheory -- | Show variants (pretty-printed closed theory).@@ -383,32 +385,49 @@ getTheoryPathMR :: TheoryIdx -> TheoryPath -> Handler RepJson-getTheoryPathMR idx path = liftIOHandler $ do- jsonValue <- withTheory idx (go path)- return $ RepJson $ toContent $ fromValue jsonValue+getTheoryPathMR idx path = do+ renderUrl <- getUrlRender+ jsonValue <- withTheory idx (go renderUrl path)+ return $ RepJson $ toContent jsonValue where -- -- Handle method paths by trying to solve the given goal/method --- go (TheoryMethod lemma proofPath i) ti = modifyTheory ti+ go _ (TheoryMethod lemma proofPath i) ti = modifyTheory ti (\thy -> return $ applyMethodAtPath thy lemma proofPath i)+ (\thy -> nextSmartThyPath thy (TheoryProof lemma proofPath)) (JsonAlert "Sorry, but the prover failed on the selected method!") -- -- Handle generic paths by trying to render them --- go _ ti = do+ go renderUrl _ ti = do let title = T.pack $ titleThyPath (tiTheory ti) path- let html = T.pack $ renderHtmlDoc $ htmlThyPath (tiTheory ti) path+ let html = T.pack $ renderHtmlDoc $ htmlThyPath renderUrl ti path return $ responseToJson (JsonHtml title (toContent html)) +-- | Run the autoprover on a given proof path.+getAutoProverR :: TheoryIdx -> TheoryPath -> Handler RepJson+getAutoProverR idx path = do+ jsonValue <- withTheory idx (go path)+ return $ RepJson $ toContent jsonValue+ where+ go (TheoryProof lemma proofPath) ti = modifyTheory ti+ (\thy -> + return $ applyProverAtPath thy lemma proofPath (mapProverProof cutOnAttackDFS autoProver))+ (\thy -> nextSmartThyPath thy path)+ (JsonAlert "Sorry, but the autoprover failed on given proof step!") + go _ _ = return . responseToJson $ JsonAlert+ "Can't run autoprover on the given theory path!"++{- -- | Show a given path within a theory (debug view). getTheoryPathDR :: TheoryIdx -> TheoryPath -> Handler RepHtml getTheoryPathDR idx path = withTheory idx $ \ti -> ajaxLayout $ do- let maybeDebug = htmlThyDbgPath (tiTheory ti) path- let maybeWidget = wrapHtmlDoc <$> maybeDebug- addWidget [HAMLET|+ -- let maybeDebug = htmlThyDbgPath (tiTheory ti) path+ -- let maybeWidget = wrapHtmlDoc <$> maybeDebug+ return [hamlet| <h2>Theory information</h2> <ul> <li>Index = #{show (tiIndex ti)}@@ -419,10 +438,14 @@ <li>PrevPath = #{show (prevThyPath (tiTheory ti) path)} <li>NextSmartPath = #{show (nextSmartThyPath (tiTheory ti) path)} <li>PrevSmartPath = #{show (prevSmartThyPath (tiTheory ti) path)}+ |]+ {- $if isJust maybeWidget <h2>Current sequent</h2><br> \^{fromJust maybeWidget} |]+ -}+-} -- | Get rendered graph for theory and given path. getTheoryGraphR :: TheoryIdx -> TheoryPath -> Handler ()@@ -438,14 +461,15 @@ sendFile "image/png" png where graphStyle d c = dotStyle d . compression c- dotStyle True = dotSequentCompact- dotStyle False = dotSequentLoose+ dotStyle True = dotSequentCompact CompactBoringNodes+ dotStyle False = dotSequentCompact FullBoringNodes compression True = compressSequent compression False = id + -- | Kill a thread (aka 'cancel request'). getKillThreadR :: Handler RepPlain-getKillThreadR = liftIOHandler $ do+getKillThreadR = do maybeKey <- lookupGetParam "path" case maybeKey of Just key0 -> do@@ -469,8 +493,9 @@ -> String -- ^ Jumping mode (smart?) -> TheoryPath -- ^ Current path -> Handler RepPlain-getNextTheoryPathR idx md path = withTheory idx $ \ti -> return $- RepPlain $ toContent $ joinPath' $ renderPath $ next md (tiTheory ti) path+getNextTheoryPathR idx md path = withTheory idx $ \ti -> do+ url <- getUrlRender <*> pure (TheoryPathMR idx $ next md (tiTheory ti) path)+ return . RepPlain $ toContent url where next "normal" = nextThyPath next "smart" = nextSmartThyPath@@ -479,13 +504,15 @@ -- | Get the 'prev' theory path for a given path. -- This function is used for implementing keyboard shortcuts. getPrevTheoryPathR :: TheoryIdx -> String -> TheoryPath -> Handler RepPlain-getPrevTheoryPathR idx md path = withTheory idx $ \ti -> return $- RepPlain $ toContent $ joinPath' $ renderPath $ prev md (tiTheory ti) path+getPrevTheoryPathR idx md path = withTheory idx $ \ti -> do+ url <- getUrlRender <*> pure (TheoryPathMR idx $ prev md (tiTheory ti) path)+ return $ RepPlain $ toContent url where prev "normal" = prevThyPath prev "smart" = prevSmartThyPath prev _ = const id +{- -- | Get the edit theory page. getEditTheoryR :: TheoryIdx -> Handler RepJson getEditTheoryR = postEditTheoryR@@ -503,13 +530,14 @@ jsonResp . JsonRedirect =<< getUrlRender <*> pure (OverviewR newIdx) where- theoryFormlet ti = fieldsToDivs $ textareaField- (FormFieldSettings+ -- theoryFormlet ti = fieldsToDivs $ textareaField+ theoryFormlet ti = textareaField+ (FieldSettings ("Edit theory source: " `T.append` name ti) (toHtml $ name ti) Nothing Nothing) (Just $ Textarea $ T.pack $ render $ prettyClosedTheory $ tiTheory ti) - exHandler :: MonadControlIO m => E.SomeException -> GenericHandler m RepJson+ exHandler :: MonadBaseControl IO m => E.SomeException -> GHandler m RepJson exHandler err = jsonResp $ JsonAlert $ T.unlines [ "Unable to load theory due to parse error!" , "Parser returned the message:"@@ -517,7 +545,9 @@ name = T.pack . get thyName . tiTheory theoryFormTpl = formTpl (EditTheoryR idx) "Load as new theory" +-} +{- -- | Get the add lemma page. getEditPathR :: TheoryIdx -> TheoryPath -> Handler RepJson getEditPathR = postEditPathR@@ -556,8 +586,9 @@ action (Just l) = "Edit lemma " ++ get lName l action Nothing = "Add new lemma" - formlet lemma = fieldsToDivs $ textareaField- (FormFieldSettings+ -- formlet lemma = fieldsToDivs $ textareaField+ formlet lemma = textareaField+ (FieldSettings (T.pack $ action lemma) (toHtml $ action lemma) Nothing Nothing)@@ -567,35 +598,23 @@ postEditPathR _ _ = jsonResp $ JsonAlert $ "Editing for this path is not implemented!"----- | Run the autoprover on a given proof path.-getAutoProverR :: TheoryIdx -> TheoryPath -> Handler RepJson-getAutoProverR idx path = liftIOHandler $ do- jsonValue <- withTheory idx (go path)- return $ RepJson $ toContent $ fromValue jsonValue- where- go (TheoryProof lemma proofPath) ti = modifyTheory ti- (\thy -> - return $ applyProverAtPath thy lemma proofPath (mapProverProof cutOnAttackDFS autoProver))- (JsonAlert "Sorry, but the autoprover failed on given proof step!")-- go _ _ = return . responseToJson $ JsonAlert- "Can't run autoprover on the given theory path!"+-} -- | Delete a given proof step. getDeleteStepR :: TheoryIdx -> TheoryPath -> Handler RepJson-getDeleteStepR idx path = liftIOHandler $ do+getDeleteStepR idx path = do jsonValue <- withTheory idx (go path)- return $ RepJson $ toContent $ fromValue jsonValue+ return $ RepJson $ toContent jsonValue where go (TheoryLemma lemma) ti = modifyTheory ti (return . removeLemma lemma)+ (const path) (JsonAlert "Sorry, but removing the selected lemma failed!") go (TheoryProof lemma proofPath) ti = modifyTheory ti (\thy -> return $ applyProverAtPath thy lemma proofPath (sorryProver "removed"))+ (const path) (JsonAlert "Sorry, but removing the selected proof step failed!") go _ _ = return . responseToJson $ JsonAlert@@ -638,8 +657,9 @@ getUnloadTheoryR :: TheoryIdx -> Handler RepPlain getUnloadTheoryR idx = do delTheory idx - redirect RedirectPermanent RootR+ redirect RootR +{- -- | Show a list of all currently running threads. getThreadsR :: Handler RepHtml getThreadsR = do@@ -647,3 +667,4 @@ defaultLayout $ do setTitle "Registered threads" addWidget (threadsTpl threads)+-}
src/Web/Theory.hs view
@@ -13,7 +13,7 @@ module Web.Theory ( htmlThyPath- , htmlThyDbgPath+-- , htmlThyDbgPath , pngThyPath , titleThyPath , theoryIndex@@ -37,6 +37,7 @@ import Data.List import Data.Monoid import qualified Data.Map as M+import qualified Data.Text as T import Control.Basics @@ -46,7 +47,6 @@ import Extension.Data.Label import qualified Text.Dot as D-import Text.Isar import Text.PrettyPrint.Html import Utils.Misc (stringSHA256) @@ -57,6 +57,20 @@ -- Various other functions ------------------------------------------------------------------------------ +-- | Extract and simplify a proof of a lemma for presentation.+extractSimplifiedLemmaProof :: Lemma IncrementalProof -> IncrementalProof+extractSimplifiedLemmaProof =+ -- Simplify variable indices just before displaying. This addresses #27.+ -- Due to lazy-evaluation the effort is linear in the proof depth. This is+ -- probably OK. Note that this implies that the displayed terms and the+ -- stored terms do not agree. This is no problem for paths, as they use+ -- relative addressing anyways.+ fmap dropMayLoop . simplifyVariableIndices . get lProof+ where+ dropMayLoop (ProofStep (SolveGoal (PremiseG p fa _)) info) =+ ProofStep (SolveGoal (PremiseG p fa False)) info+ dropMayLoop step = step+ checkProofs :: ClosedTheory -> ClosedTheory checkProofs = proveTheory checkedProver where@@ -67,12 +81,14 @@ applyMethodAtPath thy lemmaName proofPath i = do lemma <- lookupLemma lemmaName thy subProof <- get lProof lemma `atPath` proofPath- methods <- applicableProofMethods thy <$> psInfo (root subProof)+ let ctxt = getProofContext lemma thy+ methods <- applicableProofMethods ctxt <$> psInfo (root subProof) method <- if length methods >= i then Just (methods !! (i-1)) else Nothing applyProverAtPath thy lemmaName proofPath (oneStepProver method `mappend` replaceSorryProver (oneStepProver Simplify) `mappend`- replaceSorryProver (contradictionAndClauseProver)+ replaceSorryProver (contradictionAndClauseProver) `mappend`+ replaceSorryProver (oneStepProver Attack) ) applyProverAtPath :: ClosedTheory -> String -> ProofPath@@ -85,23 +101,24 @@ ------------------------------------------------------------------------------ -- | Reference a dot graph for the given path.-refDotPath :: HtmlDocument d => TheoryPath -> d-refDotPath path = closedTag "img" [("class", "graph"), ("src", imgPath)]- where imgPath = "graph/" ++ joinPath' (renderPath path)+refDotPath :: HtmlDocument d => RenderUrl -> TheoryIdx -> TheoryPath -> d+refDotPath renderUrl tidx path = closedTag "img" [("class", "graph"), ("src", imgPath)]+ where imgPath = T.unpack $ renderUrl (TheoryGraphR tidx path) getDotPath :: String -> FilePath getDotPath code = imageDir </> addExtension (stringSHA256 code) "dot" -- | Create a link to a given theory path. linkToPath :: HtmlDocument d- => TheoryPath -- ^ Path to link to.+ => RenderUrl -- ^ Url rendering function.+ -> Route WebUI -- ^ Route that should be linked. -> [String] -- ^ Additional class -> d -- ^ Document that carries the link. -> d-linkToPath path cls = withTag "a" [("class", classes), ("href", linkPath)]+linkToPath renderUrl route cls = withTag "a" [("class", classes), ("href", linkPath)] where classes = unwords $ "internal-link" : cls- linkPath = joinPath' $ renderPath path+ linkPath = T.unpack $ renderUrl route -- | Output some preformatted text. preformatted :: HtmlDocument d => Maybe String -> d -> d@@ -112,69 +129,63 @@ -- | Render a proof index relative to a theory path constructor. proofIndex :: HtmlDocument d- => (ProofPath -> TheoryPath) -- ^ Relative addressing function- -> Proof (Maybe Sequent, Bool) -- ^ The annotated incremental proof+ => RenderUrl+ -> (ProofPath -> Route WebUI) -- ^ Relative addressing function+ -> Proof (Maybe Sequent, Maybe Bool) -- ^ The annotated incremental proof -> d-proofIndex mkPath = +proofIndex renderUrl mkRoute = prettyProofWith ppStep ppCase . insertPaths where- isSolved = snd . fst . psInfo- isAnnotated = isJust . fst . fst . psInfo+ ppCase step = markStatus (snd $ fst $ psInfo step) - isSorry ps- | Sorry _ <- psMethod ps = True- | otherwise = False+ ppStep step = case fst $ psInfo step of+ (Nothing, _) -> superfluousStep+ (_, Nothing) -> stepLink ["sorry-step"] <>+ case psMethod step of+ Sorry _ -> emptyDoc+ _ -> removeStep+ (_, Just True) -> stepLink ["hl_good"]+ (_, Just False) -> stepLink ["hl_bad"]+ where+ ppMethod = prettyProofMethod $ psMethod step+ stepLink cls = linkToPath renderUrl+ (mkRoute . snd . psInfo $ step)+ ("proof-step" : cls) ppMethod - markSolved = withTag "span" [("class", "hl_solved")]+ superfluousStep = withTag "span" [("class","hl_superfluous")] ppMethod - ppStep ps- | not (isAnnotated ps) = superfluousStep ps- | isSolved ps = (markSolved $ linkToStep ["solved"] ps) <> removeStep ps- | isSorry ps = linkToStep ["unsolved", "sorry-step"] ps - | otherwise = linkToStep ["unsolved"] ps <> removeStep ps+ removeStep = linkToPath renderUrl (mkRoute . snd . psInfo $ step)+ ["remove-step"] emptyDoc - removeStep ps = linkToPath- (mkPath $ snd $ psInfo ps) ["remove-step"] emptyDoc - ppCase ps- | isSolved ps = markSolved - | otherwise = id -- superfluousStep ps = withTag "span"- [("class","hl_superfluous unsolved")] - (prettyProofMethod $ psMethod ps)- - linkToStep cls ps = linkToPath- (mkPath $ snd $ psInfo ps) ("proof-step" : cls)- (prettyProofMethod $ psMethod ps)- -- | Render the indexing links for a single lemma lemmaIndex :: HtmlDocument d- => (ProofPath -> TheoryPath) -- ^ Relative addressing function+ => RenderUrl -- ^ The url rendering function+ -> TheoryIdx -- ^ The theory index -> Lemma IncrementalProof -- ^ The lemma -> d-lemmaIndex mkPath l =- markSolved (kwLemmaModulo "E" <-> prettyLemmaName l <> colon) <->- (linkToPath (TheoryLemma $ get lName l) ["edit-link"] editPng <->- linkToPath (TheoryLemma $ get lName l) ["delete-link"] deletePng) $-$- nest 2 (markSolved $ doubleQuotes $ prettyFormulaE $ get lFormulaE l) $-$- proofIndex mkPath annotatedProof+lemmaIndex renderUrl tidx l =+ ( markStatus (snd $ psInfo $ root annPrf) $+ (kwLemmaModulo "E" <-> prettyLemmaName l <> colon) <->+ (linkToPath renderUrl lemmaRoute ["edit-link"] editPng <->+ linkToPath renderUrl lemmaRoute ["delete-link"] deletePng) $-$+ nest 2 ( sep [ prettyTraceQuantifier $ get lTraceQuantifier l+ , doubleQuotes $ prettyFormulaE $ get lFormulaE l+ ] )+ ) $-$+ proofIndex renderUrl mkRoute annPrf where editPng = png "/static/img/edit.png" deletePng = png "/static/img/delete.png" png path = closedTag "img" [("class","icon"),("src",path)] - annotatedProof = annotateProof $ get lProof l-- markSolved doc- | solved = withTag "span" [("class", "hl_solved")] doc- | otherwise = doc- where- solved = snd $ psInfo $ root annotatedProof+ annPrf = annotateLemmaProof l+ lemmaRoute = TheoryPathMR tidx (TheoryLemma $ get lName l)+ mkRoute proofPath = TheoryPathMR tidx (TheoryProof (get lName l) proofPath) -- | Render the theory index.-theoryIndex :: HtmlDocument d => ClosedTheory -> d-theoryIndex thy = foldr1 ($-$)+theoryIndex :: HtmlDocument d => RenderUrl -> TheoryIdx -> ClosedTheory -> d+theoryIndex renderUrl tidx thy = foldr1 ($-$) [ kwTheoryHeader $ get thyName thy , text "" , messageLink@@ -190,8 +201,7 @@ , kwEnd ] where- mkPath path lemma = path $ get lName lemma- lemmaIndex' lemma = lemmaIndex (mkPath TheoryProof lemma) lemma+ lemmaIndex' lemma = lemmaIndex renderUrl tidx lemma lemmas = map lemmaIndex' (getLemmas thy) rules = getClassifiedRules thy@@ -206,7 +216,7 @@ | otherwise = show nChains ++ " chains left" bold = withTag "strong" [] . text- overview n info p = linkToPath p [] (bold n <-> info)+ overview n info p = linkToPath renderUrl (TheoryPathMR tidx p) [] (bold n <-> info) messageLink = overview "Message theory" (text "") TheoryMessage ruleLink = overview "Multiset rewriting rules" rulesInfo TheoryRules reqCasesLink name k = overview name (casesInfo k) (TheoryCaseDist k 0 0)@@ -224,43 +234,62 @@ -- | A snippet that explains a sub-proof by displaying its proof state, the -- open-goals, and the new cases. subProofSnippet :: HtmlDocument d- => ClosedTheory -- ^ The theory context.- -> (ProofPath -> TheoryPath) -- ^ Relative proof adressing- -> (Int -> TheoryPath) -- ^ Relative proof method addressing+ => RenderUrl+ -> TheoryIdx -- ^ The theory index.+ -> String -- ^ The lemma.+ -> ProofPath -- ^ The proof path.+ -> ProofContext -- ^ The proof context. -> IncrementalProof -- ^ The sub-proof. -> d-subProofSnippet thy mkProofPath mkPrfMethodPath prf = +subProofSnippet renderUrl tidx lemma proofPath ctxt prf = case psInfo $ root prf of- Nothing -> text $ "no annotated sequent / " ++ nCases ++ " sub-case(s)"+ Nothing -> text $ "no annotated constraint system / " ++ nCases ++ " sub-case(s)" Just se -> vcat $- [ withTag "h3" [] (text "Graph Part of Sequent")- , refDotPath (mkProofPath [])- , text ""- , withTag "h3" [] (text "Applicable Proof Methods")- , preformatted (Just "methods") (numbered' $ proofMethods se)- , withTag "h3" [] (text "Pretty-Printed Sequent")+ prettyApplicableProofMethods se+ +++ [ text "" ]+ +++ (if hasGraphPart se+ then [ withTag "h3" [] (text "Graph Part of Constraint System")+ , refDotPath renderUrl tidx (TheoryProof lemma proofPath)+ ]+ else [ withTag "h3" [] (text "Constraint System has no Graph Part") ])+ +++ [ withTag "h3" [] (text "Pretty-Printed Constraint System") , preformatted (Just "sequent") (prettyNonGraphSequent se) , withTag "h3" [] (text $ nCases ++ " sub-case(s)") ] ++ subCases where- prettyPM (i, m) = linkToPath- (mkPrfMethodPath i) ["proof-method"] (prettyProofMethod m)+ prettyApplicableProofMethods se = case proofMethods se of+ [] -> [ withTag "h3" [] (text "Constraint System is Solved") ]+ pms -> [ withTag "h3" [] (text "Applicable Proof Methods")+ , preformatted (Just "methods") (numbered' $ map prettyPM $ zip [1..] pms)+ , text "a." <-> + linkToPath renderUrl (AutoProverR tidx (TheoryProof lemma proofPath))+ ["autoprove"] (keyword_ "autoprove")+ ] + prettyPM (i, m) = linkToPath renderUrl+ (TheoryPathMR tidx (TheoryMethod lemma proofPath i))+ ["proof-method"] (prettyProofMethod m)+ nCases = show $ M.size $ children prf- proofMethods = map prettyPM . zip [1..] . applicableProofMethods thy+ hasGraphPart se = not $ M.empty == get sNodes se+ proofMethods = applicableProofMethods ctxt subCases = concatMap refSubCase $ M.toList $ children prf refSubCase (name, prf') = [ withTag "h4" [] (text "Case" <-> text name) , maybe (text "no proof state available")- (const $ refDotPath $ mkProofPath [name])+ (const $ refDotPath renderUrl tidx $ TheoryProof lemma (proofPath ++ [name])) (psInfo $ root prf') ] + -- | A Html document representing the requires case splitting theorem. htmlCaseDistinction :: HtmlDocument d - => CaseDistKind -> (Int, CaseDistinction) -> d-htmlCaseDistinction kind (j, th) =+ => RenderUrl -> TheoryIdx -> CaseDistKind -> (Int, CaseDistinction) -> d+htmlCaseDistinction renderUrl tidx kind (j, th) = if null cases then withTag "h2" [] ppHeader $-$ withTag "h3" [] (text "No cases.") else vcat $ withTag "h2" [] ppHeader : cases@@ -268,7 +297,7 @@ cases = concatMap ppCase $ zip [1..] $ getDisj $ get cdCases th wrapP = withTag "p" [("class","monospace cases")] nCases = int $ length $ getDisj $ get cdCases th- ppPrem = nest 2 $ doubleQuotes $ prettyBigStepGoal $ get cdGoal th+ ppPrem = nest 2 $ doubleQuotes $ prettyLNFact $ get cdGoal th ppHeader = hsep [ text "Sources of" <-> ppPrem , parens $ nCases <-> text "cases"@@ -276,7 +305,7 @@ ppCase (i, (names, (conc, se))) = [ withTag "h3" [] $ fsep [ text "Source", int i, text "of", nCases , text " / named ", doubleQuotes (text name) ]- , refDotPath (TheoryCaseDist kind j i)+ , refDotPath renderUrl tidx (TheoryCaseDist kind j i) , withTag "p" [] $ ppPrem <-> text "provided by conclusion" <-> prettyNodeConc conc , wrapP $ prettyNonGraphSequent se ]@@ -284,9 +313,9 @@ name = intercalate "_" names -- | Build the Html document showing the source cases distinctions.-reqCasesSnippet :: HtmlDocument d => CaseDistKind -> ClosedTheory -> d-reqCasesSnippet kind thy = vcat $ - htmlCaseDistinction kind <$> zip [1..] (getCaseDistinction kind thy)+reqCasesSnippet :: HtmlDocument d => RenderUrl -> TheoryIdx -> CaseDistKind -> ClosedTheory -> d+reqCasesSnippet renderUrl tidx kind thy = vcat $+ htmlCaseDistinction renderUrl tidx kind <$> zip [1..] (getCaseDistinction kind thy) -- | Build the Html document showing the rules of the theory. rulesSnippet :: HtmlDocument d => ClosedTheory -> d@@ -317,25 +346,28 @@ -- | Render the item in the given theory given by the supplied path. htmlThyPath :: HtmlDocument d- => ClosedTheory -- ^ The theory to render+ => RenderUrl -- ^ The function for rendering Urls.+ -> TheoryInfo -- ^ The info of the theory to render -> TheoryPath -- ^ Path to render -> d-htmlThyPath thy path = go path+htmlThyPath renderUrl ti path = go path where go TheoryRules = rulesSnippet thy go TheoryMessage = messageSnippet thy- go (TheoryCaseDist kind _ _) = reqCasesSnippet kind thy- go (TheoryProof l p) = fromMaybe- (text "No such lemma or proof path.")- (subProofSnippet thy- (mkProofPath l p)- (TheoryMethod l p)- <$> resolveProofPath thy l p)+ go (TheoryCaseDist kind _ _) = reqCasesSnippet renderUrl tidx kind thy+ go (TheoryProof l p) = + fromMaybe (text "No such lemma or proof path.") $ do+ lemma <- lookupLemma l thy+ let ctxt = getProofContext lemma thy+ subProofSnippet renderUrl tidx l p ctxt+ <$> resolveProofPath thy l p go (TheoryLemma _) = text "Implement theory item pretty printing!" go _ = text "Unhandled theory path. This is a bug." - mkProofPath lemma path' subPath = TheoryProof lemma (path' ++ subPath)+ thy = tiTheory ti+ tidx = tiIndex ti +{- -- | Render debug information for the item in the theory given by the path. htmlThyDbgPath :: HtmlDocument d => ClosedTheory -- ^ The theory to render@@ -347,6 +379,7 @@ proof <- resolveProofPath thy l p prettySequent <$> psInfo (root proof) go _ = Nothing+-} -- | Render the image corresponding to the given theory path. pngThyPath :: FilePath -> (Sequent -> D.Dot ()) -> ClosedTheory@@ -423,7 +456,7 @@ -> Maybe IncrementalProof resolveProofPath thy lemmaName path = do lemma <- lookupLemma lemmaName thy- get lProof lemma `atPath` path+ extractSimplifiedLemmaProof lemma `atPath` path ------------------------------------------------------------------------------@@ -434,17 +467,17 @@ nextThyPath :: ClosedTheory -> TheoryPath -> TheoryPath nextThyPath thy = go where- go TheoryMain = TheoryMessage+ go TheoryHelp = TheoryMessage go TheoryMessage = TheoryRules go TheoryRules = TheoryCaseDist UntypedCaseDist 0 0 go (TheoryCaseDist UntypedCaseDist _ _) = TheoryCaseDist TypedCaseDist 0 0- go (TheoryCaseDist TypedCaseDist _ _) = fromMaybe TheoryMain firstLemma+ go (TheoryCaseDist TypedCaseDist _ _) = fromMaybe TheoryHelp firstLemma go (TheoryLemma lemma) = TheoryProof lemma [] go (TheoryProof l p) | Just nextPath <- getNextPath l p = TheoryProof l nextPath | Just nextLemma <- getNextLemma l = TheoryProof nextLemma []- | otherwise = TheoryMain- go _ = TheoryMain+ | otherwise = TheoryHelp+ go _ = TheoryHelp lemmas = map (\l -> (get lName l, l)) $ getLemmas thy firstLemma = flip TheoryProof [] . fst <$> listToMaybe lemmas@@ -460,7 +493,7 @@ prevThyPath :: ClosedTheory -> TheoryPath -> TheoryPath prevThyPath thy = go where- go TheoryMessage = TheoryMain+ go TheoryMessage = TheoryHelp go TheoryRules = TheoryMessage go (TheoryCaseDist UntypedCaseDist _ _) = TheoryRules go (TheoryCaseDist TypedCaseDist _ _) = TheoryCaseDist UntypedCaseDist 0 0@@ -471,7 +504,7 @@ | Just prevPath <- getPrevPath l p = TheoryProof l prevPath | Just prevLemma <- getPrevLemma l = TheoryProof prevLemma (lastPath prevLemma) | otherwise = TheoryCaseDist TypedCaseDist 0 0- go _ = TheoryMain+ go _ = TheoryHelp lemmas = map (\l -> (get lName l, l)) $ getLemmas thy @@ -485,21 +518,29 @@ getPrevLemma lemmaName = getPrevElement (== lemmaName) (map fst lemmas) +++-- | Interesting proof methods that are not skipped by next/prev-smart.+isInterestingMethod :: ProofMethod -> Bool+isInterestingMethod (Sorry _) = True+isInterestingMethod m = m == Attack++ -- Get 'next' smart theory path. nextSmartThyPath :: ClosedTheory -> TheoryPath -> TheoryPath nextSmartThyPath thy = go where- go TheoryMain = TheoryMessage+ go TheoryHelp = TheoryMessage go TheoryMessage = TheoryRules go TheoryRules = TheoryCaseDist UntypedCaseDist 0 0 go (TheoryCaseDist UntypedCaseDist _ _) = TheoryCaseDist TypedCaseDist 0 0- go (TheoryCaseDist TypedCaseDist _ _) = fromMaybe TheoryMain firstLemma+ go (TheoryCaseDist TypedCaseDist _ _) = fromMaybe TheoryHelp firstLemma go (TheoryLemma lemma) = TheoryProof lemma [] go (TheoryProof l p) | Just nextPath <- getNextPath l p = TheoryProof l nextPath | Just nextLemma <- getNextLemma l = TheoryProof nextLemma []- | otherwise = TheoryMain- go _ = TheoryMain+ | otherwise = TheoryHelp+ go _ = TheoryHelp lemmas = map (\l -> (get lName l, l)) $ getLemmas thy firstLemma = flip TheoryProof [] . fst <$> listToMaybe lemmas@@ -507,10 +548,9 @@ getNextPath lemmaName path = do lemma <- lookupLemma lemmaName thy let paths = getProofPaths $ get lProof lemma- let nextSteps = snd $ break ((== path) . fst) paths- if null nextSteps- then Nothing- else listToMaybe $ map fst $ filter snd $ tail nextSteps+ case dropWhile ((/= path) . fst) paths of+ [] -> Nothing+ nextSteps -> listToMaybe . map fst . filter (isInterestingMethod . snd) $ tail nextSteps getNextLemma lemmaName = getNextElement (== lemmaName) (map fst lemmas) @@ -518,7 +558,7 @@ prevSmartThyPath :: ClosedTheory -> TheoryPath -> TheoryPath prevSmartThyPath thy = go where- go TheoryMessage = TheoryMain+ go TheoryMessage = TheoryHelp go TheoryRules = TheoryMessage go (TheoryCaseDist UntypedCaseDist _ _) = TheoryRules go (TheoryCaseDist TypedCaseDist _ _) = TheoryCaseDist UntypedCaseDist 0 0@@ -527,44 +567,42 @@ | otherwise = TheoryCaseDist TypedCaseDist 0 0 go (TheoryProof l p) | Just prevPath <- getPrevPath l p = TheoryProof l prevPath- | Just firstPath <- getFirstPath l p = TheoryProof l firstPath+-- | Just firstPath <- getFirstPath l p = TheoryProof l firstPath | Just prevLemma <- getPrevLemma l = TheoryProof prevLemma (lastPath prevLemma) | otherwise = TheoryCaseDist TypedCaseDist 0 0- go _ = TheoryMain+ go _ = TheoryHelp lemmas = map (\l -> (get lName l, l)) $ getLemmas thy + {- getFirstPath lemmaName current = do lemma <- lookupLemma lemmaName thy let paths = map fst $ getProofPaths $ get lProof lemma if null paths || (head paths == current) then Nothing else Just $ head paths+ -} getPrevPath lemmaName path = do lemma <- lookupLemma lemmaName thy let paths = getProofPaths $ get lProof lemma- let prevSteps = filter snd $ fst $ break ((== path) . fst) paths- if null prevSteps- then Nothing- else Just $ fst $ last prevSteps+ case filter (isInterestingMethod . snd) . takeWhile ((/= path) . fst) $ paths of+ [] -> Nothing+ prevSteps -> Just . fst . last $ prevSteps lastPath lemmaName = last $ map fst $ getProofPaths $ get lProof $ fromJust $ lookupLemma lemmaName thy getPrevLemma lemmaName = getPrevElement (== lemmaName) (map fst lemmas) + -- | Extract proof paths out of a proof.--- Boolean value in tuple indicates if path is sorry step.-getProofPaths :: LTree CaseName (ProofStep a) -> [([String], Bool)]-getProofPaths proof = ([], isSorry proof) : go proof+getProofPaths :: LTree CaseName (ProofStep a) -> [([String], ProofMethod)]+getProofPaths proof = ([], psMethod . root $ proof) : go proof where go = concatMap paths . M.toList . children- paths (lbl, prf) = ([lbl], isSorry prf) : map (first (lbl:)) (go prf)+ paths (lbl, prf) = ([lbl], psMethod . root $ prf) : map (first (lbl:)) (go prf) - isSorry ps- | Sorry _ <- psMethod (root ps) = True- | otherwise = False -- | Get element _after_ the matching element in the list. getNextElement :: (a -> Bool) -> [a] -> Maybe a@@ -583,19 +621,35 @@ | f z = Just old | otherwise = go z zs +-- | Translate a proof status returned by 'annotateLemmaProof' to a+-- corresponding CSS class.+markStatus :: HtmlDocument d => Maybe Bool -> d -> d+markStatus Nothing = id+markStatus (Just True) = withTag "span" [("class","hl_good")]+markStatus (Just False) = withTag "span" [("class","hl_bad")]+ -- | Annotate a proof for pretty printing. -- The boolean flag indicates that the given proof step's children -- are (a) all annotated and (b) contain no sorry steps.-annotateProof :: Proof (Maybe Sequent) -> Proof (Maybe Sequent, Bool)-annotateProof (LNode (ProofStep method sequent) children')- | Nothing <- sequent = LNode (proofStep False) annotatedChildren- | Sorry _ <- method = LNode (proofStep False) annotatedChildren- | otherwise = LNode (proofStep checkChildren) annotatedChildren+annotateLemmaProof :: Lemma IncrementalProof+ -> Proof (Maybe Sequent, Maybe Bool)+annotateLemmaProof lem = + mapProofInfo (second interpret) prf where- annotatedChildren = M.map annotateProof children'- proofStep bool = ProofStep method (sequent, bool)- checkChildren = all (snd . psInfo . root . snd) $ M.toList annotatedChildren+ prf = annotateProof annotate $ extractSimplifiedLemmaProof lem+ annotate step cs = + ( psInfo step+ , mconcat $ proofStepStatus step : incomplete ++ map snd cs+ )+ where+ incomplete = if isNothing (psInfo step) then [IncompleteProof] else [] + interpret status = case (get lTraceQuantifier lem, status) of+ (_, IncompleteProof) -> Nothing+ (AllTraces, TraceFound) -> Just False+ (AllTraces, CompleteProof) -> Just True+ (ExistsTrace, TraceFound) -> Just True+ (ExistsTrace, CompleteProof) -> Just False ------------------------------------------------------------------------------ -- Html file generation@@ -659,7 +713,7 @@ , giOutDir :: FilePath -- ^ Path to the output directory. , giTheory :: ClosedTheory -- ^ Theory to output. , giCmdLine :: String -- ^ The command line that was used in this call to- -- tamarin.+ -- the Tamarin prover. , giCompress :: Bool -- ^ True if sequents should be compressed -- before visualization by unsoundly dropping -- information.
src/Web/Types.hs view
@@ -16,7 +16,7 @@ module Web.Types ( WebUI(..)- , WebUIRoute (..)+ , Route (..) , resourcesWebUI , TheoryInfo(..) , TheoryPath(..)@@ -24,13 +24,14 @@ , JsonResponse(..) , renderPath , parsePath- , joinPath' , TheoryIdx , TheoryMap , ThreadMap- , GenericHandler+ -- , GenericHandler , Handler- , GenericWidget+ -- , URL rendering function+ , RenderUrl+ -- , GenericWidget , Widget ) where@@ -38,16 +39,13 @@ import Theory import Yesod.Core-import Yesod.Helpers.Static+import Yesod.Static import Text.Hamlet-import Text.Printf import Data.Monoid (mconcat)-import Data.List (intercalate) import Data.Maybe (listToMaybe) import Data.Ord (comparing)-import Data.Char (ord, isAlphaNum) import Data.Time.LocalTime import Data.Label import Control.Concurrent@@ -55,7 +53,7 @@ import qualified Data.Map as M import qualified Data.Text as T -import Control.Monad.IO.Class+-- import Control.Monad.IO.Class import Control.Applicative ------------------------------------------------------------------------------@@ -63,12 +61,12 @@ ------------------------------------------------------------------------------ -- | Type synonym for a generic handler inside our site.-type GenericHandler m = GGHandler WebUI WebUI m-type Handler a = GHandler WebUI WebUI a+-- type GenericHandler m = GHandler WebUI WebUI m+-- type Handler a = GHandler WebUI WebUI a -- | Type synonym for a generic widget inside our site.-type GenericWidget m = GGWidget WebUI (GenericHandler m)-type Widget a = GWidget WebUI WebUI a+-- type GenericWidget m = GWidget WebUI (GenericHandler m)+-- type Widget a = GWidget WebUI WebUI a -- | Type synonym representing a numeric index for a theory. type TheoryIdx = Int@@ -87,7 +85,8 @@ -- ^ Settings for static file serving. , workDir :: FilePath -- ^ The working directory (for storing/loading theories).- , parseThy :: MonadIO m => String -> GenericHandler m ClosedTheory+ -- , parseThy :: MonadIO m => String -> GenericHandler m ClosedTheory+ , parseThy :: String -> IO ClosedTheory -- ^ Parse a closed theory according to command-line arguments. , closeThy :: OpenTheory -> IO ClosedTheory -- ^ Close an open theory according to command-line arguments.@@ -160,7 +159,7 @@ -- | Simple data type for specifying a path to a specific -- item within a theory. data TheoryPath- = TheoryMain -- ^ The main view (info about theory)+ = TheoryHelp -- ^ The help view (help and info about theory) | TheoryLemma String -- ^ Theory lemma with given name | TheoryIntrVar Int -- ^ Intruder variant (n'th from start) | TheoryCaseDist CaseDistKind Int Int -- ^ Required cases (i'th source, j'th case) @@ -172,7 +171,7 @@ -- | Render a theory path to a list of strings. renderPath :: TheoryPath -> [String]-renderPath TheoryMain = ["main"]+renderPath TheoryHelp = ["help"] renderPath TheoryRules = ["rules"] renderPath TheoryMessage = ["message"] renderPath (TheoryLemma name) = ["lemma", name]@@ -185,7 +184,7 @@ parsePath :: [String] -> Maybe TheoryPath parsePath [] = Nothing parsePath (x:xs) = case x of- "main" -> Just TheoryMain+ "help" -> Just TheoryHelp "rules" -> Just TheoryRules "message" -> Just TheoryMessage "lemma" -> parseLemma xs@@ -218,15 +217,7 @@ parseCases _ = Nothing --- | Join a path (list of strings) into a single string.--- This functions also performs escaping of special characters.-joinPath' :: [String] -> String-joinPath' = intercalate "/" . map escape- where- escape [] = []- escape (x:xs)- | isAlphaNum x = x : escape xs- | otherwise = printf "%%%02x" (ord x) ++ escape xs+type RenderUrl = Route WebUI -> T.Text ------------------------------------------------------------------------------ -- Routing@@ -254,41 +245,41 @@ -- Note that handlers ending in R are general handlers, -- whereas handlers ending in MR are for the main view -- and the ones ending in DR are for the debug view.-mkYesodData "WebUI" [PARSE_ROUTES|-/ RootR GET POST-/thy/#Int/overview OverviewR GET-/thy/#Int/source TheorySourceR GET-/thy/#Int/variants TheoryVariantsR GET-/thy/#Int/message TheoryMessageDeductionR GET-/thy/#Int/main/MP(TheoryPath) TheoryPathMR GET-/thy/#Int/debug/MP(TheoryPath) TheoryPathDR GET-/thy/#Int/graph/MP(TheoryPath) TheoryGraphR GET-/thy/#Int/autoprove/MP(TheoryPath) AutoProverR GET-/thy/#Int/next/#String/MP(TheoryPath) NextTheoryPathR GET-/thy/#Int/prev/#String/MP(TheoryPath) PrevTheoryPathR GET-/thy/#Int/save SaveTheoryR GET-/thy/#Int/download/#String DownloadTheoryR GET-/thy/#Int/edit/source EditTheoryR GET POST-/thy/#Int/edit/path/MP(TheoryPath) EditPathR GET POST-/thy/#Int/del/path/MP(TheoryPath) DeleteStepR GET-/thy/#Int/unload UnloadTheoryR GET-/kill KillThreadR GET-/threads ThreadsR GET-/robots.txt RobotsR GET-/favicon.ico FaviconR GET-/static StaticR Static getStatic+mkYesodData "WebUI" [parseRoutes|+/ RootR GET POST+/thy/#Int/overview/MP(TheoryPath) OverviewR GET+/thy/#Int/source TheorySourceR GET+-- /thy/#Int/variants TheoryVariantsR GET+/thy/#Int/message TheoryMessageDeductionR GET+/thy/#Int/main/MP(TheoryPath) TheoryPathMR GET+-- /thy/#Int/debug/MP(TheoryPath) TheoryPathDR GET+/thy/#Int/graph/MP(TheoryPath) TheoryGraphR GET+/thy/#Int/autoprove/MP(TheoryPath) AutoProverR GET+/thy/#Int/next/#String/MP(TheoryPath) NextTheoryPathR GET+/thy/#Int/prev/#String/MP(TheoryPath) PrevTheoryPathR GET+-- /thy/#Int/save SaveTheoryR GET+/thy/#Int/download/#String DownloadTheoryR GET+-- /thy/#Int/edit/source EditTheoryR GET POST+-- /thy/#Int/edit/path/MP(TheoryPath) EditPathR GET POST+/thy/#Int/del/path/MP(TheoryPath) DeleteStepR GET+/thy/#Int/unload UnloadTheoryR GET+/kill KillThreadR GET+-- /threads ThreadsR GET+/robots.txt RobotsR GET+/favicon.ico FaviconR GET+/static StaticR Static getStatic |] -- | MultiPiece instance for TheoryPath.-instance MultiPiece TheoryPath where- toMultiPiece = map T.pack . renderPath- fromMultiPiece = parsePath . map T.unpack+instance PathMultiPiece TheoryPath where+ toPathMultiPiece = map T.pack . renderPath+ fromPathMultiPiece = parsePath . map T.unpack -- Instance of the Yesod typeclass. instance Yesod WebUI where -- | The approot. We can leave this empty because the -- application is always served from the root of the server.- approot _ = T.empty+ approot = ApprootStatic T.empty -- | The default layout for rendering. defaultLayout = defaultLayout'@@ -298,7 +289,6 @@ -- cleanPath function forces canonical URLs. cleanPath _ = Right - ------------------------------------------------------------------------------ -- Default layout ------------------------------------------------------------------------------@@ -306,9 +296,11 @@ -- | Our application's default layout template. -- Note: We define the default layout here even tough it doesn't really -- belong in the "types" module in order to avoid mutually recursive modules.-defaultLayout' :: (Yesod master, Route master ~ WebUIRoute) - => GWidget sub master () -- ^ Widget to embed in layout- -> GHandler sub master RepHtml+-- defaultLayout' :: (Yesod master, Route master ~ WebUIRoute) +-- => GWidget sub master () -- ^ Widget to embed in layout+-- -> GHandler sub master RepHtml+defaultLayout' :: Yesod master =>+ GWidget sub master () -> GHandler sub master RepHtml defaultLayout' w = do page <- widgetToPageContent w message <- getMessage
tamarin-prover.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Simple name: tamarin-prover-version: 0.1.1.0+version: 0.4.0.0 license: GPL license-file: LICENSE category: Theorem Provers@@ -9,10 +9,10 @@ Simon Meier <simon.meier@inf.ethz.ch> maintainer: Simon Meier <simon.meier@inf.ethz.ch> copyright: Benedikt Schmidt, Simon Meier, ETH Zurich, 2010-2012-synopsis: The tamarin prover for security protocol analysis.+synopsis: The Tamarin prover for security protocol analysis. description: - The @tamarin@ prover is a tool for the analysis of security protocols. It+ The Tamarin prover is a tool for the analysis of security protocols. It implements a constraint solving algorithm that supports both falsification and verification of security protocols with respect to an unbounded number of sessions. The underlying security protocol model uses multiset@@ -21,21 +21,19 @@ equational theories to model the algebraic properties of cryptographic operators. .- The paper describing the theory underlying the @tamarin@ prover is- currently under submission to CSF 2012. Drop us (simon.meier\@inf.ethz.ch- or benedikt.schmidt\@inf.ethz.ch) a mail, if you would like to obtain a- copy of the paper.+ The paper describing the theory underlying the Tamarin prover was+ accepted at CSF 2012. Its extended version is available from+ <http://www.infsec.ethz.ch/research/software#TAMARIN>. .- The @tamarin@ prover supports both a batch analysis mode and the+ The Tamarin prover supports both a batch analysis mode and the interactive construction of security proofs using a GUI. Example protocols and the user guide are installed together with the prover. Just call the @tamarin-prover@ executable without any arguments to get more information. .- The @tamarin@ prover uses maude (<http://maude.cs.uiuc.edu/>) as a+ The Tamarin prover uses maude (<http://maude.cs.uiuc.edu/>) as a unification backend and GraphViz (<http://www.graphviz.org/>) to visualize- constraint systems. Detailed instructions for installing the `tamarin`- prover are given here:- <http://www.infsec.ethz.ch/research/software#TAMARIN>+ constraint systems. Detailed instructions for installing the Tamarin+ prover are given at <http://www.infsec.ethz.ch/research/software#TAMARIN>. homepage: http://www.infsec.ethz.ch/research/software#TAMARIN @@ -48,6 +46,7 @@ data-files: LICENSE AUTHORS+ CHANGES -- cached intruder variants for DH-exponentiation intruder_variants_dh.spthy@@ -65,14 +64,22 @@ etc/spthy.vim etc/filetype.vim + -- documentation+ doc/MANUAL+ -- example files- examples/UserGuide.spthy- examples/TLS.spthy- -- examples/Typing_Invariant_Example.spthy+ examples/stable/Tutorial.spthy+ examples/stable/TLS.spthy+ examples/stable/InvariantsExample.spthy -- CSF'12 case studies examples/csf12/Artificial.spthy + examples/csf12/DH2_original.spthy+ examples/csf12/KAS1.spthy+ examples/csf12/KAS2_eCK.spthy+ examples/csf12/KAS2_original.spthy+ examples/csf12/KEA_plus_KI_KCI.spthy examples/csf12/KEA_plus_KI_KCI_wPFS.spthy examples/csf12/KEA_plus_eCK.spthy@@ -89,33 +96,31 @@ examples/csf12/SignedDH_PFS.spthy examples/csf12/SignedDH_eCK.spthy - examples/csf12/STS-MAC.spthy- examples/csf12/STS-MAC-fix1.spthy- examples/csf12/STS-MAC-fix2.spthy+ examples/csf12/STS_MAC.spthy+ examples/csf12/STS_MAC_fix1.spthy+ examples/csf12/STS_MAC_fix2.spthy - examples/csf12/JKL_TS1_2004-KI.spthy- examples/csf12/JKL_TS1_2008-KI_wPFS.spthy- examples/csf12/JKL_TS1_2008-KI.spthy- examples/csf12/JKL_TS2_2004-KI_wPFS.spthy- examples/csf12/JKL_TS2_2004-KI.spthy- examples/csf12/JKL_TS2_2008-KI_wPFS.spthy- examples/csf12/JKL_TS2_2008-KI.spthy- examples/csf12/JKL_TS3_2004-KI_wPFS.spthy-nonterm- examples/csf12/JKL_TS3_2008-KI_wPFS.spthy-nonterm+ examples/csf12/JKL_TS1_2004_KI.spthy+ examples/csf12/JKL_TS1_2008_KI.spthy+ examples/csf12/JKL_TS2_2004_KI_wPFS.spthy+ examples/csf12/JKL_TS2_2008_KI_wPFS.spthy+ examples/csf12/JKL_TS3_2004_KI_wPFS.spthy_nonterm+ examples/csf12/JKL_TS3_2008_KI_wPFS.spthy_nonterm extra-source-files: .ghci interactive-only-src/Paths_tamarin_prover.hs interactive-only-src/Lexer.x - README- CHANGES - -------------- -- build flags -------------- +flag no-gui+ default: False+ description: Do not build the web-application GUI.+ flag threaded default: True description: Build with support for multithreaded execution@@ -124,7 +129,7 @@ default: True description: Build with test coverage support -Flag build-tests+flag build-tests default: False description: Build unit test driver @@ -134,61 +139,80 @@ ---------------------- executable tamarin-prover+ if flag(threaded)+ ghc-options: -threaded++ ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -rtsopts+ ghc-prof-options: -auto-all+ hs-source-dirs: src+ main-is: Main.hs++ if flag(no-gui)+ cpp-options: -DNO_GUI++ if !flag(no-gui)+ -- To help the top-down solver we put the more difficult to solve yesod+ -- dependencies up front.+ build-depends:+ bytestring == 0.9.*+ , blaze-html == 0.4.*+ , http-types == 0.6.*+ , blaze-builder == 0.3.*+ , yesod-core == 0.10.*+ , yesod-json == 0.3.*+ , yesod-static == 0.10.*+ -- , yesod-form == 0.4.* -- required once we reactivate editing+ , text == 0.11.*+ , wai == 1.1.*+ , hamlet == 0.10.*+ , warp == 1.1.*+ , aeson == 0.6.*+ , old-locale == 1.0.*+ , monad-control == 0.3.*+ , lifted-base+ , threads == 0.4.*+ build-depends: base == 4.*- , array == 0.3.*- , deepseq == 1.1.*- , containers >= 0.3 && < 0.4.2+ , bytestring == 0.9.*+ , deepseq == 1.3.*+ , array >= 0.3 && < 0.5+ , containers >= 0.4.2 && < 0.5 , mtl == 2.0.*- , cmdargs == 0.6.* && >= 0.6.8- , filepath >= 1.1 && < 1.3+ , cmdargs == 0.9.*+ , filepath >= 1.1 && < 1.4 , directory >= 1.0 && < 1.2- , process == 1.0.*+ , process == 1.1.* , parsec == 3.1.*- , bytestring == 0.9.* , safe >= 0.2 && < 0.4 , transformers == 0.2.*- , fclabels == 1.0.*+ , fclabels == 1.1.* , uniplate == 1.6.* , syb == 0.3.* && >= 0.3.3 , binary == 0.5.* , derive == 2.5.*- , time == 1.2.*- , threads == 0.4.*- , http-types == 0.6.*- , blaze-builder == 0.3.*- , yesod-core == 0.8.*- , yesod-json == 0.1.*- , yesod-static == 0.1.*- , yesod-form == 0.1.*- , text == 0.11.*- , wai == 0.4.*- , hamlet == 0.8.*- , warp == 0.4.*- , aeson == 0.3.*- , old-locale == 1.0.*- , monad-control == 0.2.*+ , time >= 1.2 && < 1.5 , parallel == 3.2.*+ , HUnit == 1.2.* - , tamarin-prover-utils == 0.1.*- , tamarin-prover-term == 0.1.*+ , tamarin-prover-utils == 0.4.*+ , tamarin-prover-term == 0.4.* - -- extra deps to get it building on GHC 7.0.3 without the new modular- --solver of cabal-install, activated with flag --solver=modular- if impl(ghc <= 7.2)- build-depends:- template-haskell == 2.5.*- , data-default == 0.2.*- , wai-extra == 0.4.3 - if flag(threaded)- ghc-options: -threaded-- ghc-options: -Wall -funbox-strict-fields -fwarn-tabs -rtsopts- main-is: Main.hs- hs-source-dirs: src- other-modules:+ Paths_tamarin_prover+ Main_NoGui+ Main_Full+ Main.Console+ Main.Environment+ Main.TheoryLoader+ Main.Utils+ Main.Mode.Test+ Main.Mode.Batch+ Main.Mode.Intruder+ Main.Mode.Interactive++ Theory.AbstractInterpretation Theory.Pretty Theory.Fact Theory.Atom@@ -204,6 +228,7 @@ Theory.Proof.CaseDistinctions Theory.Proof Theory.RuleVariants+ Theory.RuleSet Theory.Signature Theory Theory.Lexer@@ -217,3 +242,4 @@ Web.Instances Web.Handler Web.Dispatch+