diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,55 @@ +2014-06-06 John D. Ramsdell + + * cpsa.cabal (Version): Tagged as version 2.3.4 + + * doc/cpsauser.html: Commented out Diffie-Hellman algebra + description. + + * src/CPSA/Lib/Main.hs (useDiffieHellman): Added a compile time + switch that is used to disable the Diffie-Hellman algebra in a + release. + +2014-04-30 John D. Ramsdell + + * src/CPSA/Lib/Expand.hs: Added splicing to the macro expander. + The splice symbol is ^. + +2014-04-21 John D. Ramsdell + + * src/CPSA/DiffieHellman/Algebra.hs (agSolve): Added missing omit + when generating new equation. + + * src/CPSA/DiffieHellman/Algebra.hs (genVars): Removed code that + conditionally generates new variables because the condition was + not reliable. + +2014-03-07 John D. Ramsdell + + * src/CPSA/DiffieHellman/Algebra.hs: Changed the sort structure + of exponents. The sort of exponents is now expr, and there is as + subsort for basis elements called expn. Unification and matching + have been change so as to respect this sort structure. This + change allows CPSA to solve Diffie-Hellman key exchange. + +2014-02-26 John D. Ramsdell + + * src/CPSA/Lib/Algebra.hs (specialize): Expunged specialize from + the interface and the algebras. + +2014-02-25 John D. Ramsdell + + * src/CPSA/DiffieHellman/Algebra.hs (isAcquiredVar): Changed the + definition so that both variables of sort base and sort mesg are + acquired. + + * src/CPSA/Lib/Algebra.hs (Term): Renamed isMesgVar to + isAcquiredVar. + +2014-02-24 John D. Ramsdell + + * cpsa.cabal: Expunged Simple Diffie-Hellman and + Diffie-Hellman No Reciprocal algebras. + 2014-02-06 John D. Ramsdell * cpsa.cabal (Version): Tagged as version 2.3.3 diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,5 +1,17 @@ CPSA NEWS -- history of user-visible changes. +* Changes in version 2.3.4 + +** Splicing added to macros + + The macro expander supports splicing. The splicing character is + '^'. Example: (a ^(b c) d) becomes (a b c d) after macro + expansion. + +** Diffie-Hellman algebra is disabled + The implementation has never worked well enough to be anything but + experimental, so it is now enabled via a compile-time switch. + * Changes in version 2.3.3 ** Thinning has replaced pruning diff --git a/cpsa.cabal b/cpsa.cabal --- a/cpsa.cabal +++ b/cpsa.cabal @@ -1,5 +1,5 @@ Name: cpsa -Version: 2.3.3 +Version: 2.3.4 Maintainer: ramsdell@mitre.org Cabal-Version: >= 1.6 License: BSD3 @@ -127,9 +127,6 @@ CPSA.Lib.Algebra CPSA.Lib.Protocol CPSA.Lib.Strand CPSA.Lib.Loader CPSA.Lib.Displayer CPSA.Lib.Cohort CPSA.Lib.Expand CPSA.Lib.CPSA CPSA.Lib.Reduction CPSA.Basic.Algebra CPSA.DiffieHellman.Algebra - CPSA.DiffieHellman.IntLinEq CPSA.SimpleDiffieHellman.Algebra - CPSA.DiffieHellmanNoReciprocal.Algebra - CPSA.DiffieHellmanNoReciprocal.LinDiophEq Executable cpsagraph Main-Is: CPSA/Graph/Main.hs @@ -173,9 +170,6 @@ CPSA.Lib.Displayer CPSA.Lib.Cohort CPSA.Lib.CPSA CPSA.Annotations.Formulas CPSA.Annotations.Annotations CPSA.Basic.Algebra CPSA.DiffieHellman.Algebra - CPSA.DiffieHellman.IntLinEq CPSA.SimpleDiffieHellman.Algebra - CPSA.DiffieHellmanNoReciprocal.Algebra - CPSA.DiffieHellmanNoReciprocal.LinDiophEq Executable cpsaparameters Main-Is: CPSA/Parameters/Main.hs @@ -189,9 +183,6 @@ CPSA.Lib.Protocol CPSA.Lib.Strand CPSA.Lib.Loader CPSA.Lib.Displayer CPSA.Lib.Cohort CPSA.Lib.CPSA CPSA.Parameters.Flow CPSA.Basic.Algebra CPSA.DiffieHellman.Algebra - CPSA.DiffieHellman.IntLinEq CPSA.SimpleDiffieHellman.Algebra - CPSA.DiffieHellmanNoReciprocal.Algebra - CPSA.DiffieHellmanNoReciprocal.LinDiophEq Executable cpsapp Main-Is: CPSA/Pretty/Main.hs @@ -228,6 +219,3 @@ CPSA.Lib.Displayer CPSA.Lib.Cohort CPSA.Lib.CPSA CPSA.Logic.Logic CPSA.Basic.Algebra CPSA.DiffieHellman.Algebra - CPSA.DiffieHellman.IntLinEq CPSA.SimpleDiffieHellman.Algebra - CPSA.DiffieHellmanNoReciprocal.Algebra - CPSA.DiffieHellmanNoReciprocal.LinDiophEq diff --git a/doc/cpsa.bib b/doc/cpsa.bib --- a/doc/cpsa.bib +++ b/doc/cpsa.bib @@ -52,6 +52,46 @@ publisher = {The {MIT} Press}, year = 2001} +@InCollection{BaaderSnyder01, + author = {Franz Baader and Wayne Snyder}, + title = {Unification Theory}, + booktitle = {Handbook of Automated Reasoning}, + publisher = {The {MIT} Press}, + year = 2001, + editor = {Alan Robinson and Andrei Voronkov}, + volume = 1, + chapter = 8, + note = {\url{http://www.cs.bu.edu/~snyder/publications/UnifChapter.pdf‎}}} + +@InProceedings{KepserRichts99, + author = {Stephan Kepser and J\"{o}rn Richts}, + title = {Optimisation Techniques for Combining Constraint Solvers}, + booktitle = {Frontiers of Combining Systems 2}, + pages = {193--210}, + year = 1999, + editor = {Maarten de Rijke and Dov Gabbay}, + address = {Asmsterdam}, + publisher = {Research Studies Press/Wiley}, + note = {\url{http://tcl.sfs.uni-tuebingen.de/~kepser/papers/optimisation.ps.gz}}} + +@InProceedings{MeadowsNarendran02, + author = {Catherine Meadows and Paliath Narendran}, + title = {A Unification Algorithm for the Group Diffie-Hellman Protocol}, + booktitle = {WITS 2002}, + month = jan, + year = 2002, + note = {\url{http://www.dsi.unive.it/IFIPWG1_7/WITS2002/prog/annotated_program.html}}} + +@PhdThesis{Liu12, + author = {Zhiqiang Liu}, + title = {Dealing Efficiently with Exclusive OR, Abelian + Groups and Homomorphism in Cryptographic Protocol + Analysis}, + school = {Clarkson University}, + year = 2012, + month = sep, + note = {\url{http://people.clarkson.edu/~clynch/papers/}}} + @article{GoguenMeseguer92, author = "Joseph A. Goguen and Jose Meseguer", title = "Order-Sorted Algebra {I}: Equational Deduction for Multiple @@ -328,15 +368,32 @@ publisher = {Springer-Verlag} } -@Unpublished{Ramsdell12, +@Misc{Ramsdell12, author = {John D. Ramsdell}, - title = {Deducing Security Goals From Shape Analysis Sentences}, - note = {\url{http://arxiv.org/abs/1204.0480v1}}, - OPTkey = {}, - month = jan, + title = {Deducing Security Goals from Shape Analysis Sentences}, + howpublished = {The MITRE Corporation}, + month = apr, year = 2012, - OPTannote = {} + note = {\url{http://arxiv.org/abs/1204.0480}}} + +@TechReport{Ramsdell13, + title = {Proving Security Goals With Shape Analysis Sentences}, + author = {John D.~Ramsdell}, + institution = {The MITRE Corporation}, + year = 2013, + month = sep, + number = {MTR130488}, + note = {\url{http://arxiv.org/abs/1403.3563}}, } + +@Misc{RamsdellEtAl14, + author = {John D. Ramsdell and Daniel J. Dougherty and + Joshua D. Guttman and Paul D. Rowe}, + title = {A Hybrid Analysis for Security Protocols with State}, + howpublished = {The MITRE Corporation and Worcester Polytechnic Institute}, + month = apr, + year = 2014, + note = {\url{http://arxiv.org/abs/1404.3899}}} @TechReport{RamsdellEtAl09, author = {John D. Ramsdell and Joshua D. Guttman and diff --git a/doc/cpsadesign.pdf b/doc/cpsadesign.pdf Binary files a/doc/cpsadesign.pdf and b/doc/cpsadesign.pdf differ diff --git a/doc/cpsadesign.tex b/doc/cpsadesign.tex --- a/doc/cpsadesign.tex +++ b/doc/cpsadesign.tex @@ -1236,9 +1236,10 @@ \begin{center} Base sort symbols: \dom{name}, \dom{text}, \dom{data}, \dom{skey}, \dom{akey}, \dom{expn}\\ -Non-base sort symbols: \dom{mesg}, \dom{base} \\[1ex] +Non-base sort symbols: \dom{mesg}, \dom{base}, \dom{expr} \\[1ex] Subsorts: \dom{name}, \dom{text}, \dom{data}, \dom{akey}, \dom{skey}, -\dom{expn}, $\dom{base}<\dom{mesg}$\\[1ex] +\dom{expr}, $\dom{base}<\dom{mesg}$, +$\dom{expn}<\dom{expr}$\\[1ex] \begin{tabular}{@{}ll} $\enc{\cdot}{(\cdot)}\colon\dom{mesg}\times\dom{mesg}\rightarrow\dom{mesg}$ &Encryption\\ @@ -1255,32 +1256,27 @@ & Long term shared key\\ $\gen\colon\dom{base}$ & Generator constant\\ -$(\cdot)^{(\cdot)}\colon\dom{base}\times\dom{expn}\rightarrow\dom{base}$ -& Exponentiation +$(\cdot)^{(\cdot)}\colon\dom{base}\times\dom{expr}\rightarrow\dom{base}$ +& Exponentiation\\ +$(\cdot\cdot)\colon\dom{expr}\times\dom{expr}\rightarrow\dom{expr}$ +& Group operation\\ +$(1/\cdot)\colon\dom{expr}\rightarrow\dom{expr}$ +& Group inverse\\ +$1\colon\dom{expr}$ +& Group identity \end{tabular}\\[1ex] Axioms: $(x^{-1})^{-1}\approx x$ for $x\colon\dom{akey}$\\ -$(h^x)^y\approx (h^y)^x$ for $h\colon\dom{base}$ and -$x,y\colon\dom{expn}$\\[1ex] +$1x\approx x$, $x(1/x)\approx 1$, $xy\approx yx$, $x(yz)=(xy)z$,\\ +$h^1=h$, and $(h^x)^y=h^{xy}$ for $h\colon\dom{base}$ and +$x,y,z\colon\dom{expr}$ +\\[1ex] \caption{Diffie-Hellman Signature}\label{tab:dh} \end{center} \end{table} Table~\ref{tab:dh} contains the signature used for Diffie-Hellman -analysis. In this algebra, there is an equation for the commutativity -of exponents, but there is no equation for associativity. Therefore, -this algebra cannot be used to analyze group Diffie-Hellman protocols. - -The equation for exponentiation is $(h^x)^y\approx (h^y)^x$ for -$h\colon\dom{base}$ and $x,y\colon\dom{expn}$. Unification and -matching in this algebra produce a finite number of most general -unifiers, that is, the unification type is finitary. For example, -$\{x\mapsto u,y\mapsto v\}$ and $\{x\mapsto \gen^v,u\mapsto \gen^y\}$ -and unify $x^y$ and $u^v$. Unification is finitary because of an -approximation. To unify $a^{xy}$ and~$b^{wz}$, we unify $a^{xy}$ -with~$\gen^{uv}$ and $\gen^{vu}$ with~$b^{wz}$, where~$u$ and~$v$ are -freshly generated variables. In other words, for the purpose of -unification only, the equation for exponentiation is -$(\gen^x)^y\approx (\gen^y)^x$. +analysis. In this algebra, messages of the form $\gen^x$ for +$x\colon\dom{expn}$ are also atoms. \bibliography{cpsa} \bibliographystyle{plain} diff --git a/doc/cpsaintroslides.pdf b/doc/cpsaintroslides.pdf Binary files a/doc/cpsaintroslides.pdf and b/doc/cpsaintroslides.pdf differ diff --git a/doc/cpsaoverview.pdf b/doc/cpsaoverview.pdf Binary files a/doc/cpsaoverview.pdf and b/doc/cpsaoverview.pdf differ diff --git a/doc/cpsaprimer.pdf b/doc/cpsaprimer.pdf Binary files a/doc/cpsaprimer.pdf and b/doc/cpsaprimer.pdf differ diff --git a/doc/cpsaspec.pdf b/doc/cpsaspec.pdf Binary files a/doc/cpsaspec.pdf and b/doc/cpsaspec.pdf differ diff --git a/doc/cpsaspec.tex b/doc/cpsaspec.tex --- a/doc/cpsaspec.tex +++ b/doc/cpsaspec.tex @@ -178,7 +178,7 @@ order-sorted quotient term algebras~\cite{GoguenMeseguer92} for message algebras. This formalism enables the use of well-known algorithms for unification and matching in the presences of equations -and sorts~\cite[Chapter~8]{RobinsonVoronkov01}. +and sorts~\cite{BaaderSnyder01}. This paper makes no attempt to provide a general introduction to order-sorted quotient term algebras. We use a message algebra called diff --git a/doc/cpsauser.html b/doc/cpsauser.html --- a/doc/cpsauser.html +++ b/doc/cpsauser.html @@ -140,8 +140,8 @@ EVENT ::= (send TERM) | (recv TERM) ROLE-ALIST ::= (non-orig POS-TERM*) ROLE-ALIST | (pen-non-orig POS-TERM*) ROLE-ALIST - | (uniq-orig TERM*) ROLE-ALIST | ... - | (priority NODE-INT*) SKEL-ALIST + | (uniq-orig TERM*) ROLE-ALIST + | (priority POS-INT*) ROLE-ALIST | ... POS-TERM ::= TERM | (INT TERM) PROT-ALIST ::= ... @@ -149,7 +149,10 @@

The protocol ID is a symbol that names the protocol, and the role ID is a symbol that names the role. The ALG symbol identifies the algebra used by the protocol. For the Basic Cryptographic Algebra, the -symbol is basic. The var form contains symbols that +symbol is basic. + +The var form contains symbols that declare the sort of the variables used in this role. The set of sort symbols is algebra specific. The protocol association list has no predefined keys, while the role association list has three. The value @@ -242,23 +245,59 @@ (operation collapsed INT INT), where the two INTs identify the strands merged. Shape collapsing is used to find related shapes.

+ +

Macros and Includes

-

After reading the input, cpsa expands macros before in analyzing +

After reading the input, cpsa expands macros before analyzing the results. A macro definition is a top-level form.

(defmacro (NAME ARG*) BODY)
-

The cpsa program expands all calls to macros in non-macro defining -S-expressions using the macros that have been defined previously. A macro -definition can be used to expand a call if the first element of a list matches -the name of the macro, and the length of the remaining elements in the list -matches the length of the macro's argument list. When two macros definitions -are applicable, the last definition takes precedence. The cpsa program -omits macro definitions from its output.

+

The cpsa program expands all calls to macros in +non-macro defining S-expressions using the macros that have been +defined previously. A macro definition can be used to expand a call if +the first element of a list matches the name of the macro, and the +length of the remaining elements in the list matches the length of the +macro's argument list. When two macros definitions are applicable, the +last definition takes precedence. The cpsa program omits +macro definitions from its output.

+

After expanding a list, elements of the list of the + form (^ ...) are spliced into the output. + Thus (a ^(b c) d) becomes + (a b c d) after macro expansion.

+

A source file can be included within another with the top-level include form,

@@ -361,7 +400,7 @@ from roles, but may be overridden in a skeleton with a priority comment of the form (priority (n p)), -where n is a node. +where n is a node.

Visualization

diff --git a/doc/index.html b/doc/index.html --- a/doc/index.html +++ b/doc/index.html @@ -55,9 +55,10 @@

New users should study CPSA's analysis of the following protocols in order, Blanchet (blanchet.xhtml), Needham-Schroeder - (ns.xhtml), Woo-Lam (woolam.xhtml), Yahalom - (yahalom.xhtml), ffgg (ffgg.xhtml), and finally - Otway-Rees (or.xhtml). When studying the full output, + (ns.xhtml), Woo-Lam (woolam.xhtml), + Yahalom (yahalom.xhtml), ffgg + (ffgg.xhtml), and finally Otway-Rees + (or.xhtml). When studying the full output, simultaneously display the extracted shapes. The shapes file has an extension of _shapes.xhtml.

diff --git a/doc/macros.tex b/doc/macros.tex --- a/doc/macros.tex +++ b/doc/macros.tex @@ -1,5 +1,5 @@ \newcommand{\cpsa}{\textsc{cpsa}} -\newcommand{\version}{2.3.3} +\newcommand{\version}{2.3.4} \newcommand{\cpsacopying}{\begingroup \renewcommand{\thefootnote}{}\footnotetext{{\copyright} 2010 The MITRE Corporation. Permission to copy without fee all or part of diff --git a/doc/ns.scm b/doc/ns.scm --- a/doc/ns.scm +++ b/doc/ns.scm @@ -1,6 +1,6 @@ (herald "Needham-Schroeder Public-Key Protocol" (comment "This protocol contains a man-in-the-middle" - "attack discovered by Galvin Lowe.")) + "attack discovered by Gavin Lowe.")) ;;; Used to generate output for inclusion in the primer. ;;; Use margin = 60 (-m 60) to generate the output. diff --git a/doc/readme.html b/doc/readme.html --- a/doc/readme.html +++ b/doc/readme.html @@ -9,3 +9,4 @@

Start here.

+ diff --git a/src/CPSA/Annotations/Main.hs b/src/CPSA/Annotations/Main.hs --- a/src/CPSA/Annotations/Main.hs +++ b/src/CPSA/Annotations/Main.hs @@ -17,14 +17,10 @@ import CPSA.Annotations.Annotations import qualified CPSA.Basic.Algebra import qualified CPSA.DiffieHellman.Algebra -import qualified CPSA.DiffieHellmanNoReciprocal.Algebra -import qualified CPSA.SimpleDiffieHellman.Algebra -- Algebra names algs :: [String] -algs = [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name, - CPSA.DiffieHellmanNoReciprocal.Algebra.name, - CPSA.SimpleDiffieHellman.Algebra.name] +algs = [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name] main :: IO () main = @@ -40,13 +36,6 @@ go (step h alg CPSA.Basic.Algebra.origin margin) p [] | alg == CPSA.DiffieHellman.Algebra.name -> go (step h alg CPSA.DiffieHellman.Algebra.origin margin) p [] - | alg == CPSA.DiffieHellmanNoReciprocal.Algebra.name -> - go (step h alg - CPSA.DiffieHellmanNoReciprocal.Algebra.origin margin) - p [] - | alg == CPSA.SimpleDiffieHellman.Algebra.name -> - go (step h alg CPSA.SimpleDiffieHellman.Algebra.origin margin) - p [] | otherwise -> abort ("Bad algebra: " ++ alg) hClose h diff --git a/src/CPSA/Basic/Algebra.hs b/src/CPSA/Basic/Algebra.hs --- a/src/CPSA/Basic/Algebra.hs +++ b/src/CPSA/Basic/Algebra.hs @@ -10,6 +10,52 @@ -- modify it under the terms of the BSD License as published by the -- University of California. +-------------------------------------------------------------------- + +-- The Basic Crypto Order-Sorted Signature is + +-- Sorts: mesg, text, data, name, skey, akey, and string +-- +-- Subsorts: text, data, name, skey, akey < mesg +-- +-- Operations: +-- cat : mesg X mesg -> mesg Pairing +-- enc : mesg X mesg -> mesg Encryption +-- hash : mesg -> mesg Hashing +-- string : mesg Tag constants +-- ltk : name X name -> skey Long term shared key +-- pubk : name -> akey Public key of principal +-- pubk : string X name -> akey Tagged public key of principal +-- invk : akey -> akey Inverse of asymmetric key +-- +-- Atoms: messages of sort text, data, name, skey, and akey. + +-- Variables of sort string are forbidden. + +-- The implementation exploits the isomorphism between order-sorted +-- algebras and many-sorted algebras by adding inclusion operations to +-- produce an equivalent Basic Crypto Many-Sorted Signature. There is +-- an inclusion operation for each subsort of mesg. + +-- Sorts: mesg, text, data, name, skey, akey, and string +-- +-- Operations: +-- cat : mesg X mesg -> mesg Pairing +-- enc : mesg X mesg -> mesg Encryption +-- hash : mesg -> mesg Hashing +-- string : mesg Tag constants +-- ltk : name X name -> skey Long term shared key +-- pubk : name -> akey Public key of principal +-- pubk : string X name -> akey Tagged public key of principal +-- invk : akey -> akey Inverse of asymmetric key +-- text : text -> mesg Sort text inclusion +-- data : data -> mesg Sort date inclusion +-- name : name -> mesg Sort name inclusion +-- skey : skey -> mesg Sort skey inclusion +-- akey : akey -> mesg Sort akey inclusion + +-- In both algebras, invk(invk(t)) = t for all t of sort akey + {-# LANGUAGE MultiParamTypeClasses #-} module CPSA.Basic.Algebra (name, origin) where @@ -55,48 +101,6 @@ cloneId :: Gen -> Id -> (Gen, Id) cloneId gen x = freshId gen (idName x) --- The Basic Crypto Order-Sorted Signature is - --- Sorts: mesg, text, data, name, skey, akey, and string --- --- Subsorts: text, data, name, skey, akey < mesg --- --- Operations: --- cat : mesg X mesg -> mesg Pairing --- enc : mesg X mesg -> mesg Encryption --- hash : mesg -> mesg Hashing --- string : mesg Tag constants --- ltk : name X name -> skey Long term shared key --- pubk : name -> akey Public key of principal --- pubk : string X name -> akey Tagged public key of principal --- invk : akey -> akey Inverse of asymmetric key - --- Variables of sort string are forbidden. - --- The implementation exploits the isomorphism between order-sorted --- algebras and many-sorted algebras by adding inclusion operations to --- produce an equivalent Basic Crypto Many-Sorted Signature. There is --- an inclusion operation for each subsort of mesg. - --- Sorts: mesg, text, data, name, skey, akey, and string --- --- Operations: --- cat : mesg X mesg -> mesg Pairing --- enc : mesg X mesg -> mesg Encryption --- hash : mesg -> mesg Hashing --- string : mesg Tag constants --- ltk : name X name -> skey Long term shared key --- pubk : name -> akey Public key of principal --- pubk : string X name -> akey Tagged public key of principal --- invk : akey -> akey Inverse of asymmetric key --- text : text -> mesg Sort text inclusion --- data : data -> mesg Sort date inclusion --- name : name -> mesg Sort name inclusion --- skey : skey -> mesg Sort skey inclusion --- akey : akey -> mesg Sort akey inclusion - --- In both algebras, invk(invk(t)) = t for all t of sort akey - -- Operations other than the tag constant constructor data Symbol = Text -- Text @@ -146,9 +150,9 @@ varId (F Akey [I x]) = x varId _ = error "Algebra.varId: term not a variable with its sort" -isMesgVar :: Term -> Bool -isMesgVar (I _) = True -isMesgVar _ = False +isAcquiredVar :: Term -> Bool +isAcquiredVar (I _) = True +isAcquiredVar _ = False -- A list of terms are well-formed if each one has the correct -- structure and every occurrence of an identifier in a term has the @@ -309,7 +313,7 @@ S.member t knowns || ba t0 && ba t1 ba t@(F Hash [t1]) = S.member t knowns || ba t1 - ba t = isAtom t && not (S.member t unguessable) + ba t = isAtom t && S.notMember t unguessable -- Compute the decomposition given some known terms and some unguessable -- atoms. The code is quite tricky. It iterates until the known @@ -431,7 +435,7 @@ instance C.Term Term where isVar = isVar - isMesgVar = isMesgVar + isAcquiredVar = isAcquiredVar isAtom = isAtom termsWellFormed = termsWellFormed occursIn = occursIn @@ -779,7 +783,7 @@ where loop _ [] = True loop s (I x:e) = - not (S.member x s) && loop (S.insert x s) e + S.notMember x s && loop (S.insert x s) e loop _ _ = False instance C.Env Term Gen Subst Env where @@ -792,7 +796,6 @@ [(g, e)] else [] - specialize = id substitution = substitution reify = reify matchRenaming (_, e) = matchRenaming e diff --git a/src/CPSA/DiffieHellman/Algebra.hs b/src/CPSA/DiffieHellman/Algebra.hs --- a/src/CPSA/DiffieHellman/Algebra.hs +++ b/src/CPSA/DiffieHellman/Algebra.hs @@ -1,1779 +1,2133 @@ --- Experimental Diffie-Hellman Algebra implementation - --- This module is an experimental version of Diffie-Hellman in which --- exponents form an Abelian group. There are many issues to be --- resolved before this version of Diffie-Hellman can be used. - --- The module implements a many-sorted algebra, but is used as an --- order-sorted algebra. It exports a name, and the origin used to --- generate variables. - --- Copyright (c) 2009 The MITRE Corporation --- --- This program is free software: you can redistribute it and/or --- modify it under the terms of the BSD License as published by the --- University of California. - -{-# LANGUAGE MultiParamTypeClasses #-} - -module CPSA.DiffieHellman.Algebra (name, origin) where - -import Control.Monad (foldM) -import qualified Data.List as L -import qualified Data.Set as S -import Data.Set (Set) -import qualified Data.Map as M -import Data.Map (Map) -import Data.Char (isDigit) -import qualified CPSA.Lib.CPSA as C -import CPSA.Lib.CPSA (SExpr(..), Pos, annotation) -import qualified CPSA.DiffieHellman.IntLinEq as I - -{-- Debugging support -import System.IO.Unsafe - -z :: Show a => a -> b -> b -z x y = unsafePerformIO (print x >> return y) - -zz :: Show a => a -> a -zz x = z x x - -zn :: Show a => a -> Maybe b -> Maybe b -zn x Nothing = z x Nothing -zn _ y = y - -zf :: Show a => a -> Bool -> Bool -zf x False = z x False -zf _ y = y - -zt :: Show a => a -> Bool -> Bool -zt x True = z x True -zt _ y = y ---} - -{- Export iUnify and iMatch for GHCi for debugging - -For this to work, you must install the package bytestring-handle from -Hackage and tell GHCi that it is not hidden on the command line or -within GHCi with: - -:set -package bytestring-handle - --} - -{-- -import System.IO (Handle) -import Data.ByteString.Lazy.Char8 (pack) -import Data.ByteString.Handle -import Control.Exception (try) -import System.IO.Unsafe - -stringHandle :: String -> IO Handle -stringHandle s = readHandle False (pack s) - -stringPosHandle :: String -> IO C.PosHandle -stringPosHandle s = - do - h <- stringHandle s - C.posHandle "" h - -stringLoad :: String -> IO [SExpr Pos] -stringLoad s = - do - h <- stringPosHandle s - loop h [] - where - loop h xs = - do - x <- C.load h - case x of - Nothing -> - return $ reverse xs - Just x -> - loop h (x : xs) - -sLoad :: String -> Maybe [SExpr Pos] -sLoad s = - unsafePerformIO (stringLoad s >>= return . Just) - --- Test unification - -iUnify :: String -> String -> String -> Maybe Subst -iUnify vars t t' = - iRun unify emptySubst vars t t' - --- Test matching - -iMatch :: String -> String -> String -> Maybe Env -iMatch vars t t' = - iRun match emptyEnv vars t t' - -iRun :: (Term -> Term -> (Gen, a) -> Maybe (Gen, a)) -> a -> - String -> String -> String -> Maybe a -iRun f mt vars t t' = - do - vars <- sLoad vars - [t] <- sLoad t - [t'] <- sLoad t' - (gen, vars) <- loadVars origin vars - t <- loadTerm vars t - t' <- loadTerm vars t' - (_, a) <- f t t' (gen, mt) - return a - -gRun :: Gen -> Term -> a -> a -gRun (Gen n) t a = - foldVars f a t - where - f a t = - case varId t of - Id (m, _) | m >= n -> error ("Bad gen " ++ show n) - _ -> a - -gMatch :: Term -> Term -> GenEnv -> Maybe GenEnv -gMatch t t' r@(g, _) = gRun g t' (match t t' r) - -gUnify :: Term -> Term -> GenSubst -> Maybe GenSubst -gUnify t t' r@(g, _) = gRun g (F Cat [t, t']) (unify t t' r) ---} - -name :: String -name = "experimental-diffie-hellman" - --- An identifier - -newtype Id = Id (Integer, String) deriving Show - --- The integer distinguishes an identifier, the string is for printing. - -instance Eq Id where - (Id (x, _)) == (Id (x', _)) = x == x' - -instance Ord Id where - compare (Id (x, _)) (Id (x', _)) = compare x x' - -idName :: Id -> String -idName (Id (_, name)) = name - --- Counter used for generating fresh identifiers. - -newtype Gen = Gen (Integer) deriving Show - -origin :: Gen -origin = Gen (0) - -freshId :: Gen -> String -> (Gen, Id) -freshId (Gen (i)) name = (Gen (i + 1), Id (i, name)) - -cloneId :: Gen -> Id -> (Gen, Id) -cloneId gen x = freshId gen (idName x) - -mash :: Gen -> Gen -> Gen -mash (Gen i) (Gen j) = Gen (max i j) - --- A term in an Abelian group is a map from identifiers to non-zero integers. - -type Group = Map Id Int - -isGroupVar :: Group -> Bool -isGroupVar t = - M.size t == 1 && head (M.elems t) == 1 - --- Assumes isGroupVar t == True! -getGroupVar :: Group -> Id -getGroupVar x = head $ M.keys x - -groupVar :: Id -> Term -groupVar x = G $ M.singleton x 1 - -invert :: Group -> Group -invert t = M.map negate t - -expg :: Group -> Int -> Group -expg _ 0 = M.empty -expg t 1 = t -expg t n = M.map (* n) t - -mul :: Group -> Group -> Group -mul t t' = - M.foldrWithKey f t' t -- Fold over the mappings in t - where - f x c t = -- Alter the mapping of - M.alter (g c) x t -- variable x in t - g c Nothing = -- Variable x not currently mapped - Just c -- so add a mapping - g c (Just c') -- Variable x maps to c' - | c + c' == 0 = Nothing -- Delete the mapping - | otherwise = Just $ c + c' -- Adjust the mapping - -group :: [(Id, Int)] -> Group -group assocs = - foldr f M.empty assocs - where - f (x, c) t = mul (expg (M.singleton x 1) c) t - --- Function symbols--see foldVar to see the arity of each symbol. -data Symbol - = Text -- Text atom - | Data -- Another text-like atom - | Name -- Principal atom - | Skey -- Symmetric key atom - | Base -- Base of an exponentiated atom - | Ltk -- Long term shared symmetric key - | Akey -- Asymmetric key atom - | Invk -- Inverse of asymmetric key - | Pubk -- Public asymmetric key of a principal - | Genr -- The generator constant for the group - | Exp -- Exponentiation function symbol - | Cat -- Term concatenation - | Enc -- Encryption - deriving (Show, Eq, Ord, Enum, Bounded) - --- A Basic Crypto Algebra Term - -data Term - = I !Id - | C !String - | F !Symbol ![Term] - | G !Group -- An exponent, an Abelian group - deriving Show - -equalTerm :: Term -> Term -> Bool -equalTerm (I x) (I y) = x == y -equalTerm (C c) (C c') = c == c' -equalTerm (F Invk [F Invk [t]]) t' = equalTerm t t' -equalTerm t (F Invk [F Invk [t']]) = equalTerm t t' -equalTerm (F Exp [t0, G t1]) t' | M.null t1 = equalTerm t0 t' -equalTerm t (F Exp [t0, G t1]) | M.null t1 = equalTerm t t0 -equalTerm (F Exp [F Exp [t, G t0], G t1]) t' = - equalTerm (F Exp [t, G (mul t0 t1)]) t' -equalTerm t (F Exp [F Exp [t', G t0], G t1]) = - equalTerm t (F Exp [t', G (mul t0 t1)]) -equalTerm (F s u) (F s' u') = - s == s' && equalTermLists u u' -equalTerm (G t) (G t') = t == t' -equalTerm _ _ = False - -equalTermLists :: [Term] -> [Term] -> Bool -equalTermLists [] [] = True -equalTermLists (t : u) (t' : u') = - equalTerm t t' && equalTermLists u u' -equalTermLists _ _ = False - -instance Eq Term where - (==) = equalTerm - --- Term comparison respecting the axiom - -compareTerm :: Term -> Term -> Ordering -compareTerm (I x) (I y) = compare x y -compareTerm (C c) (C c') = compare c c' -compareTerm (F Invk [F Invk [t]]) t' = compareTerm t t' -compareTerm t (F Invk [F Invk [t']]) = compareTerm t t' -compareTerm (F Exp [t0, G t1]) t' | M.null t1 = compareTerm t0 t' -compareTerm t (F Exp [t0, G t1]) | M.null t1 = compareTerm t t0 -compareTerm (F Exp [F Exp [t, G t0], G t1]) t' = - compareTerm (F Exp [t, G (mul t0 t1)]) t' -compareTerm t (F Exp [F Exp [t', G t0], G t1]) = - compareTerm t (F Exp [t', G (mul t0 t1)]) -compareTerm (F s u) (F s' u') = - case compare s s' of - EQ -> compareTermLists u u' - o -> o -compareTerm (G t) (G t') = compare t t' -compareTerm (I _) (C _) = LT -compareTerm (C _) (I _) = GT -compareTerm (I _) (F _ _) = LT -compareTerm (F _ _) (I _) = GT -compareTerm (I _) (G _) = LT -compareTerm (G _) (I _) = GT -compareTerm (C _) (F _ _) = LT -compareTerm (F _ _) (C _) = GT -compareTerm (C _) (G _) = LT -compareTerm (G _) (C _) = GT -compareTerm (F _ _) (G _) = LT -compareTerm (G _) (F _ _) = GT - -compareTermLists :: [Term] -> [Term] -> Ordering -compareTermLists [] [] = EQ -compareTermLists (t : u) (t' : u') = - case compareTerm t t' of - EQ -> compareTermLists u u' - o -> o -compareTermLists [] _ = LT -compareTermLists _ [] = GT - -instance Ord Term where - compare = compareTerm - --- Basic terms are introduced by defining a function used to decide if --- a term is well-formed. The context of an occurrence of an identifier --- determines its sort. A term that contains just an identifier and its --- sort information is called a variable. The sort of a variable is --- one of mesg, text, data, name, skey, and akey. - --- Terms that represent variables. -isVar :: Term -> Bool -isVar (I _) = True -- Sort: mesg -isVar (F s [I _]) = - -- Sorts: text, data, name, skey, and akey - s == Text || s == Data || s == Name || s == Skey || s == Akey || s == Base -isVar (G x) = isGroupVar x -isVar _ = False - --- Extract the identifier from a variable -varId :: Term -> Id -varId (I x) = x -varId (F Text [I x]) = x -varId (F Data [I x]) = x -varId (F Name [I x]) = x -varId (F Skey [I x]) = x -varId (F Akey [I x]) = x -varId (F Base [I x]) = x -varId (G x) | isGroupVar x = getGroupVar x -varId _ = error "Algebra.varId: term not a variable with its sort" - -isMesgVar :: Term -> Bool -isMesgVar (I _) = True -isMesgVar _ = False - --- A list of terms are well-formed if each one has the correct --- structure and every occurrence of an identifier in a term has the --- same sort. Variable environments are used to check the sort --- condition. It maps an identifier to a variable that contains the --- identifier. - --- termsWellFormed u ensures all terms in u use each identifier at the --- same sort, and makes sure every term has the correct structure. -termsWellFormed :: [Term] -> Bool -termsWellFormed u = - loop emptyVarEnv u - where - loop _ [] = True - loop env (t : u) = - case termWellFormed env t of - Nothing -> False - Just env' -> loop env' u - -newtype VarEnv = VarEnv (Map Id Term) deriving Show - -emptyVarEnv :: VarEnv -emptyVarEnv = VarEnv M.empty - --- Check the structure and sort condition. - -termWellFormed :: VarEnv -> Term -> Maybe VarEnv -termWellFormed xts t@(I x) = - extendVarEnv xts x t -- Mesg variable -termWellFormed xts t@(F Text [I x]) = - extendVarEnv xts x t -- Text variable -termWellFormed xts t@(F Data [I x]) = - extendVarEnv xts x t -- Data variable -termWellFormed xts t@(F Name [I x]) = - extendVarEnv xts x t -- Name variable -termWellFormed xts t@(F Skey [I x]) = - extendVarEnv xts x t -- Symmetric key variable -termWellFormed xts (F Skey [F Ltk [I x, I y]]) = - -- Long term shared symmetric key - doubleTermWellFormed xts (F Name [I x]) (F Name [I y]) -termWellFormed xts (F Akey [t]) = -- Asymmetric key terms - case t of - I x -> extendVarEnv xts x (F Akey [I x]) - F Invk [I x] -> extendVarEnv xts x (F Akey [I x]) - F Pubk [I x] -> extendVarEnv xts x (F Name [I x]) - F Pubk [C _, I x] -> extendVarEnv xts x (F Name [I x]) - F Invk [F Pubk [I x]] -> extendVarEnv xts x (F Name [I x]) - F Invk [F Pubk [C _, I x]] -> extendVarEnv xts x (F Name [I x]) - _ -> Nothing -termWellFormed xts (F Base [t]) = - baseVarEnv xts t - where - baseVarEnv xts t@(I x) = - extendVarEnv xts x (F Base [t]) - baseVarEnv xts (F Genr []) = - Just xts - baseVarEnv xts (F Exp [t0, G t1]) = - do - xts <- baseVarEnv xts t0 - termWellFormed xts (G t1) - baseVarEnv _ _ = Nothing -termWellFormed xts (G t) = - foldM expnVarEnv xts (M.keys t) - where - expnVarEnv xts x = - extendVarEnv xts x (groupVar x) -termWellFormed xts (C _) = - Just xts -- Tags -termWellFormed xts (F Cat [t0, t1]) = - doubleTermWellFormed xts t0 t1 -- Concatenation -termWellFormed xts (F Enc [t0, t1]) = - doubleTermWellFormed xts t0 t1 -- Encryption -termWellFormed _ _ = Nothing - --- Extend when sorts agree -extendVarEnv :: VarEnv -> Id -> Term -> Maybe VarEnv -extendVarEnv (VarEnv env) x t = - case M.lookup x env of - Nothing -> Just $ VarEnv $ M.insert x t env - Just t' -> if t == t' then Just (VarEnv env) else Nothing - -doubleTermWellFormed :: VarEnv -> Term -> Term -> Maybe VarEnv -doubleTermWellFormed xts t0 t1 = - do - xts <- termWellFormed xts t0 - termWellFormed xts t1 - --- Is the sort of the term a base sort? -isAtom :: Term -> Bool -isAtom (I _) = False -isAtom (C _) = False -isAtom (F s _) = - s == Text || s == Data || s == Name || s == Skey || s == Akey -isAtom (G _) = True - --- Does a term occur in another term? -occursIn :: Term -> Term -> Bool -occursIn (G t) (G t') = - all f (M.assocs t) - where - f (x, n) = - let n' = M.findWithDefault 0 x t' in - n > 0 && n' >= n || n < 0 && n' <= n -occursIn t t' = - t == t' || - case t' of - F _ u -> any (occursIn t) u - _ -> False - --- Fold f through a term applying it to each variable in the term. -foldVars :: (a -> Term -> a) -> a -> Term -> a -foldVars f acc t@(I _) = f acc t -- Mesg variable -foldVars f acc t@(F Text [I _]) = f acc t -- Text variable -foldVars f acc t@(F Data [I _]) = f acc t -- Data variable -foldVars f acc t@(F Name [I _]) = f acc t -- Name variable -foldVars f acc t@(F Skey [I _]) = - f acc t -- Symmetric key variable -foldVars f acc (F Skey [F Ltk [I x, I y]]) = - -- Long term shared symmetric key - f (f acc (F Name [I x])) (F Name [I y]) -foldVars f acc t@(F Akey [I _]) = f acc t -- Asymmetric keys -foldVars f acc (F Akey [F Invk [I x]]) = f acc (F Akey [I x]) -foldVars f acc (F Akey [F Pubk [I x]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Pubk [C _, I x]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Invk [F Pubk [I x]]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Invk [F Pubk [C _, I x]]]) = f acc (F Name [I x]) -foldVars f acc (F Base [t]) = - baseAddVars acc t - where - baseAddVars acc t@(I _) = - f acc (F Base [t]) - baseAddVars acc (F Genr []) = - acc - baseAddVars acc (F Exp [t0, G t1]) = - foldVars f (baseAddVars acc t0) (G t1) - baseAddVars _ _ = error "Algebra.foldVars: Bad term" -foldVars f acc (G t) = - foldl expnAddVars acc (M.keys t) - where - expnAddVars acc x = - f acc (groupVar x) -foldVars _ acc (C _) = acc -- Tags -foldVars f acc (F Cat [t0, t1]) = -- Concatenation - foldVars f (foldVars f acc t0) t1 -foldVars f acc (F Enc [t0, t1]) = -- Encryption - foldVars f (foldVars f acc t0) t1 -foldVars _ _ t = error $ "Algebra.foldVars: Bad term " ++ show t - --- Fold f through a term applying it to each term that is carried by the term. -foldCarriedTerms :: (a -> Term -> a) -> a -> Term -> a -foldCarriedTerms f acc t@(F Cat [t0, t1]) = -- Concatenation - foldCarriedTerms f (foldCarriedTerms f (f acc t) t0) t1 -foldCarriedTerms f acc t@(F Enc [t0, _]) = -- Encryption - foldCarriedTerms f (f acc t) t0 -foldCarriedTerms f acc t@(F Base [F Exp [_, t1]]) = -- Exponents - f (f acc t) t1 -foldCarriedTerms f acc t = f acc t -- atoms and tags - --- Is a term carried by another term? -carriedBy :: Term -> Term -> Bool -carriedBy t t' = - t == t' || - case t' of - F Cat [t0, t1] -> carriedBy t t0 || carriedBy t t1 - F Enc [t0, _] -> carriedBy t t0 - _ -> False - --- The key used to decrypt an encrypted term, otherwise Nothing. -decryptionKey :: Term -> Maybe Term -decryptionKey (F Enc [_, t]) = Just (inv t) -decryptionKey _ = Nothing - -buildable :: Set Term -> Set Term -> Term -> Bool -buildable knowns unguessable term = - ba term - where - ba (I _) = True -- A mesg sorted variable is always buildable - ba (C _) = True -- So is a tag - ba (F Cat [t0, t1]) = - ba t0 && ba t1 - ba t@(F Enc [t0, t1]) = - S.member t knowns || ba t0 && ba t1 - ba (F Base [t]) = bb t - ba t = isAtom t && not (S.member t unguessable) - -- Buildable base term - bb (I _) = True -- A variable of sort base is always buildable - bb (F Genr []) = True -- and so in the generator - bb t@(F Exp [t0, G t1]) = - S.member (F Base [t]) knowns || ba t0 && be t1 - bb (_) = False - -- Buildable exponent - be t = - -- This is a hack. One should really solve a - -- linear equation here - any (instOf $ stripExpn ids t) kns - -- Exponent variables with origination assumptions - ids = getExpnOrigAssumptions unguessable - -- Known exponent without non-known variables - kns = map (stripExpn ids) (getExpns knowns) - -getExpnOrigAssumptions :: Set Term -> [Id] -getExpnOrigAssumptions terms = - concatMap f $ S.elems terms - where - f (G t) = M.keys t -- This is an approximation - f _ = [] - -stripExpn :: [Id] -> Group -> Group -stripExpn ids grp = - foldl f grp $ M.keys grp - where - f grp key - | notElem key ids = M.delete key grp - | otherwise = grp - -getExpns :: Set Term -> [Group] -getExpns terms = - foldl f [M.empty] $ S.elems terms - where - f a (G t) = t:a - f a _ = a - -termGen :: Group -> Gen -termGen t = - Gen (1 + maxl (map idInt (M.keys t))) - where - idInt (Id (i, _)) = i - maxl [] = 0 - maxl xs = maximum xs - -instOf :: Group -> Group -> Bool -instOf grp pat = - maybe False (const True) (match (G pat) (G grp) (gen, emptyEnv)) - where - gen = mash (termGen grp) (termGen pat) - --- Compute the decomposition given some known terms and some unguessable --- atoms. The code is quite tricky. It iterates until the known --- terms don't change. The known terms ends up with all the --- encryptions that are known. -decompose :: Set Term -> Set Term -> (Set Term, Set Term) -decompose knowns unguessable = - loop unguessable knowns S.empty [] - where - loop unguessable knowns old [] - | old == knowns = (knowns, unguessable) -- Done - | otherwise = loop unguessable knowns knowns (S.elems knowns) - loop unguessable knowns old (t@(F Cat _) : todo) = - loop unguessable (decat t (S.delete t knowns)) old todo - loop unguessable knowns old ((F Enc [t0, t1]) : todo) - | buildable knowns unguessable (inv t1) = -- Add plaintext - loop unguessable (decat t0 knowns) old todo - | otherwise = loop unguessable knowns old todo - -- New case here: don't delete exponentiated values - loop unguessable knowns old (F Base [F Exp [_, _]] : todo) = - loop unguessable knowns old todo - -- New case here: don't delete exponents that - -- aren't in unguessable - loop unguessable knowns old (t@(G _) : todo) - | S.notMember t unguessable = - loop unguessable knowns old todo - loop unguessable knowns old (t : todo) = - loop (S.delete t unguessable) (S.delete t knowns) old todo - -- Decat - decat (F Cat [t0, t1]) s = decat t1 (decat t0 s) - decat t s = S.insert t s - --- Inverts an asymmetric key -inv :: Term -> Term -inv (F Akey [F Invk [t]]) = F Akey [t] -inv (F Akey [t]) = F Akey [F Invk [t]] -inv (I _) = error "Algebra.inv: Cannot invert a variable of sort mesg" -inv t = t - --- Extracts every encryption that is carried by a term along with its --- encryption key. -encryptions :: Term -> [(Term, [Term])] -encryptions t = - reverse $ loop t [] - where - loop (F Cat [t, t']) acc = - loop t' (loop t acc) - loop t@(F Enc [t', t'']) acc = - loop t' (adjoin (t, [t'']) acc) - loop t@(F Base [F Exp [_, t'']]) acc = - adjoin (t, [t'']) acc - loop _ acc = acc - adjoin x xs - | x `elem` xs = xs - | otherwise = x : xs - --- Returns the encryptions that carry the target. If the target is --- carried outside all encryptions, or is exposed because a decription --- key is derivable, Nothing is returned. -protectors :: (Term -> Bool) -> Term -> Term -> Maybe [Term] -protectors derivable target source = - do - ts <- bare source S.empty - return $ S.elems ts - where - bare source _ - | source == target = Nothing - bare (F Cat [t, t']) acc = - maybe Nothing (bare t') (bare t acc) - bare t@(F Enc [t', key]) acc = - if target `carriedBy` t' then - if derivable (inv key) then - bare t' acc - else - Just (S.insert t acc) - else - Just acc - bare t@(F Base [F Exp [_, t'']]) acc - | target == t'' = Just (S.insert t acc) - bare _ acc = Just acc - --- Support for data flow analysis of traces. A flow rule maps an --- initial set of atoms and a set of available terms to sets of pairs --- of the same sets. -type FlowRule = (Set Term, Set Term) -> Set (Set Term, Set Term) - --- Combine flow rules sequentially. -comb :: FlowRule -> FlowRule -> FlowRule -comb f g x = - S.fold h S.empty (g x) - where - h a s = S.union (f a) s - --- Analyze a term as a sent term. -outFlow :: Term -> FlowRule -outFlow t a@(_, available) - | S.member t available = S.singleton a -outFlow (I _) _ = S.empty -outFlow (C _) a = S.singleton a -outFlow (F Cat [t0, t1]) a = -- Construct non-atoms - comb (outFlow t1) (outFlow t0) a -outFlow (F Enc [t0, t1]) a = - comb (outFlow t1) (outFlow t0) a -outFlow t (initial, available) = -- Don't look inside atoms - S.singleton (S.insert t initial, S.insert t available) - --- Analyze a term as a received term. -inFlow :: Term -> FlowRule -inFlow (C _) a = S.singleton a -inFlow (F Cat [t0, t1]) a = -- Try to receive components - S.union -- in both orders - (comb (inFlow t1) (inFlow t0) a) - (comb (inFlow t0) (inFlow t1) a) -inFlow t@(F Enc [t0, t1]) (initial, available) = - S.union -- Encryption can be built - (outFlow t (initial, available)) -- or decrypted - (comb (inFlow t0) (outFlow (inv t1)) a) - where -- Derive decryption key first - a = (initial, S.insert t available) -inFlow t (initial, available) = - S.singleton (initial, S.insert t available) - -instance C.Term Term where - isVar = isVar - isMesgVar = isMesgVar - isAtom = isAtom - termsWellFormed = termsWellFormed - occursIn = occursIn - foldVars = foldVars - foldCarriedTerms = foldCarriedTerms - carriedBy = carriedBy - decryptionKey = decryptionKey - decompose = decompose - buildable = buildable - encryptions = encryptions - protectors = protectors - outFlow = outFlow - inFlow = inFlow - loadTerm = loadTerm - --- Places - --- A place names a one subterm within a term. It is a list of --- integers giving a path through a term to that named subterm. Each --- integer in the list identifies the subterm in a function --- application on the path to the named subterm. The integer is the --- index of the subterm in the application's list of terms. - --- The places and replace code fail to find the variable --- (F Akey [I x]) in (F Akey [Invk [I x]]). - -newtype Place = Place [Int] deriving Show - --- Returns the places a variable occurs within a term. -places :: Term -> Term -> [Place] -places var source = - f [] [] source - where - f paths path source - | var == source = Place (reverse path) : paths - f paths path (F _ u) = - g paths path 0 u - f paths path (G t) = - groupPlaces (varId var) paths path 0 (linearize t) - f paths _ _ = paths - g paths _ _ [] = paths - g paths path i (t : u) = - g (f paths (i: path) t) path (i + 1) u - -linearize :: Group -> [Id] -linearize t = - do - (x, n) <- M.assocs t - replicate (if n >= 0 then n else negate n) x - -groupPlaces :: Id -> [Place] -> [Int] -> Int -> [Id] -> [Place] -groupPlaces _ paths _ _ [] = paths -groupPlaces x paths path i (y:ys) = - let paths' = if x == y then - Place (reverse (i : path)) : paths - else paths in - groupPlaces x paths' path (i + 1) ys - --- Returns the places a term is carried by another term. -carriedPlaces :: Term -> Term -> [Place] -carriedPlaces target source = - f [] [] source - where - f paths path source - | target == source = Place (reverse path) : paths - f paths path (F Cat [t, t']) = - f (f paths (0 : path) t) (1 : path) t' - f paths path (F Enc [t, _]) = - f paths (0 : path) t - f paths path (F Base [F Exp [_, t]]) = - f paths (1 : 0 : path) t - f paths _ _ = paths - --- Replace a variable within a term at a given place. -replace :: Term -> Place -> Term -> Term -replace var (Place ints) source = - loop ints source - where - loop [] _ = var - loop (i : path) (F s u) = - F s (C.replaceNth (loop path (u !! i)) i u) - loop [i] (G t) = - groupReplace (varId var) i (factors t) - loop _ _ = error "Algebra.replace: Bad path to term" - -factors :: Group -> [(Id, Int)] -factors t = - do - (x, n) <- M.assocs t - case n >= 0 of - True -> replicate n (x, 1) - False -> replicate (negate n) (x, -1) - -groupReplace :: Id -> Int -> [(Id, Int)] -> Term -groupReplace x i factors = - let (_, n) = factors !! i in - G $ group $ C.replaceNth (x, n) i factors - --- Return the ancestors of the term at the given place. -ancestors :: Term -> Place -> [Term] -ancestors source (Place ints) = - loop [] ints source - where - loop ts [] _ = ts - loop ts (i: path) t@(F _ u) = - loop (t : ts) path (u !! i) - loop ts [_] t@(G _) = t : ts - loop _ _ _ = error "Algebra.ancestors: Bad path to term" - -instance C.Place Term Place where - places = places - carriedPlaces = carriedPlaces - replace = replace - ancestors = ancestors - --- Rename the identifiers in a term. Gen keeps the state of the --- renamer. (Question: should alist be replaced by a Map?) -clone :: Gen -> Term -> (Gen, Term) -clone gen t = - (gen', t') - where - (_, gen', t') = cloneTerm ([], gen) t - cloneTerm (alist, gen) t = - case t of -- The association list maps - I x -> -- identifiers to identifier. - case lookup x alist of - Just y -> (alist, gen, I y) - Nothing -> - let (gen', y) = cloneId gen x in - ((x, y) : alist, gen', I y) - C c -> (alist, gen, C c) - F sym u -> - let (alist', gen', u') = - foldl cloneTermList (alist, gen, []) u in - (alist', gen', F sym $ reverse u') - G t -> - let (alist', gen', ts) = - foldl cloneGroupList (alist, gen, []) (M.assocs t) in - (alist', gen', G $ group ts) - cloneTermList (alist, gen, u) t = - let (alist', gen', t') = cloneTerm (alist, gen) t in - (alist', gen', t' : u) - cloneGroupList (alist, gen, ts) (x, n) = - case lookup x alist of - Just y -> (alist, gen, (y, n) : ts) - Nothing -> - let (gen', y) = cloneId gen x in - ((x, y) : alist, gen', (y, n) : ts) - -instance C.Gen Term Gen where - origin = origin - clone = clone - loadVars = loadVars - --- Functions used in both unification and matching - -type IdMap = Map Id Term - -emptyIdMap :: IdMap -emptyIdMap = M.empty - --- Apply a substitution to a term -idSubst :: IdMap -> Term -> Term -idSubst subst (I x) = - M.findWithDefault (I x) x subst -idSubst _ t@(C _) = t -idSubst subst (F Invk [t]) = - case idSubst subst t of - F Invk [t] -> t -- (invk (invk x)) = x - t -> F Invk [t] -idSubst subst (F Exp [t0, G t1]) = - case idSubst subst t0 of -- (exp (exp g x) y) = (exp g (mul x y)) - F Exp [t0', G t1'] -> - case mul t1' $ groupSubst subst t1 of - t2 | M.null t2 -> t0' - | otherwise -> F Exp [t0', G t2] - t -> expSubst subst t t1 -idSubst subst (F s u) = - F s (map (idSubst subst) u) -idSubst subst (G t) = - G $ groupSubst subst t - -expSubst :: IdMap -> Term -> Group -> Term -expSubst subst t0 t1 = - case groupSubst subst t1 of - t1' | M.null t1' -> t0 -- (exp g (one)) = g - | otherwise -> F Exp [t0, G t1'] - -groupSubst :: IdMap -> Group -> Group -groupSubst subst t = - M.foldrWithKey f M.empty t - where - f x n t = - mul (expg (groupLookup subst x) n) t - -groupLookup :: IdMap -> Id -> Group -groupLookup subst x = - case M.findWithDefault (groupVar x) x subst of - G t -> t - w -> error ("Algebra.groupLookup: Bad substitution: " ++ - show x ++ " -> " ++ show w) - -showMap :: (Show a, Show b) => Map a b -> ShowS -showMap m = - showAssocs (M.assocs m) - where - showAssocs [] = id - showAssocs ((x,y):m) = - showString "\n " . shows x . showString " -> " . - shows y . showAssocs m - --- Unification and substitution - --- The rewrite rules used are: --- --- (vars (h base) (x y expn)) --- --- 1. ((exp h x) y) ==> (exp h (mul x y)) --- 2. (exp h (one)) ==> h --- 3. unify((exp(h, x)), (exp(h, y)), s) ==> --- unify(x, y, s) --- 4 unify((exp(h, x)), (exp((gen), y)), s) ==> --- unify(h, (exp gen (mul y (rec x))), s) --- 5. unify((exp((gen), x)), (exp(h, y)), s) ==> --- unify((exp(h, x)), (exp((gen), y)), s) - -newtype Subst = Subst IdMap deriving (Eq, Ord) - -instance Show Subst where - showsPrec _ (Subst s) = showString "Subst (" . showMap s . showChar ')' - -emptySubst :: Subst -emptySubst = Subst emptyIdMap - --- Apply a substitution created by unification -substitute :: Subst -> Term -> Term -substitute (Subst s) t = - idSubst s t - --- Composition of substitutions - --- substitute (compose s0 s1) t = substitute s0 (substitute s1 t) - --- 1. apply s0 to range of s1 to obtain s2; --- 2. remove bindings is s0 where domains of s0 and s1 overlap to form s3; --- 3. remove trivial bindings from s2 to form s4; and --- 4. take the union of s4 and s3. - -compose :: Subst -> Subst -> Subst -compose (Subst s0) (Subst s1) = - let s2 = M.map (substitute (Subst s0)) s1 -- Step 1 - s4 = M.filterWithKey nonTrivialBinding s2 in -- Step 3 - Subst (M.union s4 s0) -- Steps 2 and 4, union is left-biased - -nonTrivialBinding :: Id -> Term -> Bool -nonTrivialBinding x (I y) = x /= y -nonTrivialBinding _ _ = True - --- During unification, variables determined to be equal are collected --- into an equivalence class. Multiple lookups of each variable in --- the internal representation of a substitution finds the canonical --- representive of the class. The chase function finds the current --- canonical representitive. - --- Get the canonical representative of equivalent identifiers making use --- of this algebra's axiom. -chase :: Subst -> Term -> Term -chase (Subst s) (I x) = - case M.lookup x s of - Nothing -> I x - Just t -> chase (Subst s) t -chase s (F Invk [t]) = chaseInvk s t -chase s (F Exp [t0, G t1]) = chaseExp s t0 t1 -chase _ t = t - -chaseInvk :: Subst -> Term -> Term -chaseInvk (Subst s) (I x) = - case M.lookup x s of - Nothing -> F Invk [I x] - Just t -> chaseInvk (Subst s) t -chaseInvk s (F Invk [t]) = chase s t -chaseInvk _ t = F Invk [t] - -chaseExp :: Subst -> Term -> Group -> Term -chaseExp s t0 t1 - | M.null t1 = chase s t0 -chaseExp s (I x) t1 = - case chase s (I x) of - F Exp [t0', G t1'] -> chaseExp s t0' (mul t1 t1') - t0 -> F Exp [t0, chaseGroup s t1] -chaseExp s (F Exp [t0', G t1']) t1 = - chaseExp s t0' (mul t1 t1') -chaseExp s t0 t1 = F Exp [t0, chaseGroup s t1] - -chaseGroup :: Subst -> Group -> Term -chaseGroup (Subst s) x = G $ groupSubst s x - --- Does x occur in t? -occurs :: Id -> Term -> Bool -occurs x (I y) = x == y -occurs _ (C _) = False -occurs x (F _ u) = any (occurs x) u -occurs x (G t) = elem x (M.keys t) - -type GenSubst = (Gen, Subst) - -unifyChase :: Term -> Term -> GenSubst -> Maybe GenSubst -unifyChase t t' (g, s) = unifyTerms (chase s t) (chase s t') (g, s) - -unifyTerms :: Term -> Term -> GenSubst -> Maybe GenSubst -unifyTerms (I x) (I y) (g, Subst s) - | x == y = Just (g, Subst s) - | otherwise = Just (g, Subst $ M.insert x (I y) s) -unifyTerms (I x) t (g, Subst s) - | occurs x t = Nothing - | otherwise = Just (g, Subst $ M.insert x t s) -unifyTerms t (I x) s = unifyTerms (I x) t s -unifyTerms (C c) (C c') s - | c == c' = Just s - | otherwise = Nothing -unifyTerms (F Invk [I x]) (F Pubk [I y]) s = - unifyTerms (I x) (F Invk [F Pubk [I y]]) s -unifyTerms (F Invk [I x]) (F Pubk [C c, I y]) s = - unifyTerms (I x) (F Invk [F Pubk [C c, I y]]) s -unifyTerms (F Pubk [I x]) (F Invk [I y]) s = - unifyTerms (I y) (F Invk [F Pubk [I x]]) s -unifyTerms (F Pubk [C c, I x]) (F Invk [I y]) s = - unifyTerms (I y) (F Invk [F Pubk [C c, I x]]) s -unifyTerms (F Exp [t0, G t1]) (F Exp [t0', G t1']) s = - unifyExp t0 t1 t0' t1' s -unifyTerms (F sym u) (F sym' u') s - | sym == sym' = unifyTermLists u u' s - | otherwise = Nothing -unifyTerms (G t) (G t') s = - Just $ unifyGroup t t' s -unifyTerms _ _ _ = Nothing - -unifyExp :: Term -> Group -> Term -> Group -> GenSubst -> Maybe GenSubst -unifyExp t0 t1 t0' t1' s - | t0 == t0' = Just $ unifyGroup t1 t1' s -unifyExp (I x) t1 (F Genr []) t1' (g, Subst s) - | t1 == t1' = - Just (g, Subst $ M.insert x (F Genr []) s) - | otherwise = - Just (g, Subst (M.insert - x - (F Exp [F Genr [], G $ mul t1' (invert t1)]) - s)) -unifyExp (F Genr []) t1 (I x) t1' s = - unifyExp (I x) t1' (F Genr []) t1 s -unifyExp _ _ _ _ _ = Nothing - -unifyTermLists :: [Term] -> [Term] -> GenSubst -> Maybe GenSubst -unifyTermLists [] [] s = Just s -unifyTermLists (t : u) (t' : u') s = - maybe Nothing (unifyTermLists u u') (unifyChase t t' s) -unifyTermLists _ _ _ = Nothing - -unifyGroup :: Group -> Group -> GenSubst -> GenSubst -unifyGroup t0 t1 (g, Subst s) = - case matchGroup (groupSubst s $ mul t0 $ invert t1) M.empty S.empty g of - Nothing -> error "Algebra.unifyGroup: unification failed" - Just (_, g', s') -> (g', Subst $ M.union s' s) - --- The exported unifier converts the internal representation of a --- substitution into the external form using chaseMap. - -unify :: Term -> Term -> GenSubst -> Maybe GenSubst -unify t t' s = - do - (g, s) <- unifyChase t t' s - return (g, chaseMap s) - --- Apply the chasing version of substitution to the range of s. - -chaseMap :: Subst -> Subst -chaseMap (Subst s) = - Subst $ M.map (substChase (Subst s)) s - --- A chasing version of substitution. - -substChase :: Subst -> Term -> Term -substChase subst t = - case chase subst t of - t@(I _) -> t - t@(C _) -> t - F Invk [t] -> - case substChase subst t of - F Invk [t] -> t -- Apply axiom - t -> F Invk [t] - F Exp [t0, G t1] -> - case substChase subst t0 of - F Exp [t0', G t1'] -> - case mul t1' $ groupChase subst t1 of - t2 | M.null t2 -> t0' - | otherwise -> F Exp [t0', G t2] - t -> expChase subst t t1 - F s u -> - F s (map (substChase subst) u) - G t -> G $ groupChase subst t - -expChase :: Subst -> Term -> Group -> Term -expChase subst t0 t1 = - case groupChase subst t1 of - t1' | M.null t1' -> t0 - | otherwise -> F Exp [t0, G t1'] - -groupChase :: Subst -> Group -> Group -groupChase (Subst subst) t = groupSubst subst t - -instance C.Subst Term Gen Subst where - emptySubst = emptySubst - substitute = substitute - unify t t' s = maybe [] (: []) $ unify t t' s - compose = compose - --- Matching and instantiation - -newtype Env = Env (Set Id, IdMap) deriving (Eq, Ord) - -instance Show Env where - showsPrec _ (Env (v, r)) = - showString "Env (\n " . shows v . - showChar ',' . showMap r . showChar ')' - --- An environment may contain an explicit identity mapping, whereas a --- substitution is erroneous if it has one. The set of variables --- associated with a map is the variables in the range that were --- generated by matching and should be treated as variables when using --- unification to perform matching. The other variables in the range --- are treated as constants. - --- An environment contains an IdMap and the set of variables --- generated while matching. - -emptyEnv :: Env -emptyEnv = Env (S.empty, emptyIdMap) - --- Apply a substitution created my matching -instantiate :: Env -> Term -> Term -instantiate (Env (_, r)) t = idSubst r t - --- Matching - -type GenEnv = (Gen, Env) - --- The matcher has the property that when pattern P and term T match --- then instantiate (match P T emptyEnv) P = T. -match :: Term -> Term -> GenEnv -> Maybe GenEnv -match (I x) t (g, Env (v, r)) = - case M.lookup x r of - Nothing -> Just (g, Env (v, M.insert x t r)) - Just t' -> if t == t' then Just (g, Env (v, r)) else Nothing -match (C c) (C c') r = if c == c' then Just r else Nothing -match (F Exp [t0, G t1]) (F Exp [t0', G t1']) r - = matchExp t0 t1 t0' t1' r -match (F s u) (F s' u') r - | s == s' = matchLists u u' r -match (F Invk [t]) t' r = - match t (F Invk [t']) r -match (G t) (G t') (g, Env (v, r)) = - do - let (t0, t0') = merge t t' r - (v, g, r') <- matchGroup t0 t0' v g - return (g, Env (v, M.union r' r)) -match _ _ _ = Nothing - -matchExp :: Term -> Group -> Term -> Group -> GenEnv -> Maybe GenEnv -matchExp (I x) t1 t0' t1' r@(_, Env (_, e)) = - case M.lookup x e of - Just (F Exp [t0'', G t1'']) - | t0' == t0'' -> match (G t1) (G (mul t1' (invert t1''))) r - _ -> matchLists [I x, G t1] [t0', G t1'] r -matchExp (F Genr []) t1 t0' t1' r = - matchLists [F Genr [], G t1] [t0', G t1'] r -matchExp _ _ _ _ _ = error "Algebra.matchExp: Bad match term" - -matchLists :: [Term] -> [Term] -> GenEnv -> Maybe GenEnv -matchLists [] [] r = Just r -matchLists (t : u) (t' : u') r = - maybe Nothing (matchLists u u') (match t t' r) -matchLists _ _ _ = Nothing - -merge :: Group -> Group -> IdMap -> (Group, Group) -merge t t' r = - (group t0, t0') - where - (t0, t0') = loop (M.assocs t) ([], t') - loop [] acc = acc - loop (p@(x, n) : t0) (t1, t1') = - case M.lookup x r of - Nothing -> loop t0 (p : t1, t1') - Just (G t) -> - loop t0 (t1, mul (expg t (negate n)) t1') - Just t -> - error $ "Algebra.merge: expecting an expn but got " ++ show t - -matchGroup :: Group -> Group -> Set Id -> Gen -> Maybe (Set Id, Gen, IdMap) -matchGroup t0 t1 v g = - case partition t0 t1 v of - ([], []) -> return (v, g, emptyIdMap) - ([], _) -> Nothing - (t0, t1) -> - do - subst <- I.intLinEq (map snd t0, map snd t1) - return $ mgu v (map fst t0) (map fst t1) subst g - -type Coeff = [(Id, Int)] - --- Move variables on the RHS of the equation to the LHS -partition :: Group -> Group -> Set Id -> (Coeff, Coeff) -partition t0 t1 v = - (v0 ++ map (\(x,n) -> (x, negate n)) v1, c1) - where - v0 = M.assocs t0 - (v1, c1) = L.partition f (M.assocs t1) - f (x, _) = S.member x v - -mgu :: Set Id -> [Id] -> [Id] -> I.Subst -> Gen -> (Set Id, Gen, IdMap) -mgu v _ _ [] gen = (v, gen, emptyIdMap) -mgu v vars syms subst gen = - (v', gen', foldl f emptyIdMap (zip vars [0..])) - where - (gen', genSyms) = genVars vars (length (fst (snd (head subst)))) gen - v' = foldl (flip S.insert) v genSyms - f s (x, n) = - case lookup n subst of - Just (factors, consts) -> - M.insert x (g factors consts) s - Nothing -> - M.insert x (groupVar $ genSyms !! n) s - g factors consts = - G $ group (zip genSyms factors ++ zip syms consts) - -genVars :: [Id] -> Int -> Gen -> (Gen, [Id]) -genVars [] _ _ = - error "Algebra.genVars: no variables to clone" --- let (g', id) = freshId g "dh" in --- genVars [id] n g' -genVars vars n g = - loop n vars (g, []) - where - loop n [] (g, ids) = - loop n vars (g, ids) - loop n (v:vs) (g, ids) - | n <= 0 = (g, ids) - | otherwise = - case cloneId g v of - (g, id) -> loop (n - 1) vs (g, id : ids) - --- Does every varible in ts not occur in the domain of e? --- Trivial bindings in e are ignored. -identityEnvFor :: GenEnv -> [Term] -> Maybe GenEnv -identityEnvFor ge ts = - let env@(_, Env (_, r)) = nonTrivialEnv ge in - if all (allId $ flip S.notMember $ M.keysSet r) ts then - Just env - else - Nothing - -allId :: (Id -> Bool) -> Term -> Bool -allId f (I x) = f x -allId _ (C _) = True -allId f (F _ u) = all (allId f) u -allId f (G t) = all f (M.keys t) - --- Eliminate all trivial bindings so that an environment can be used --- as a substitution. -nonTrivialEnv :: GenEnv -> GenEnv -nonTrivialEnv (g, Env (v, r)) = - nonGroupEnv (M.assocs r) M.empty [] - where - nonGroupEnv [] env grp = - groupEnv g v env grp grp - nonGroupEnv ((x, I y):r) env grp - | x == y = nonGroupEnv r env grp - nonGroupEnv ((x, G y):r) env grp - | isGroupVar y && varId (G y) == x = - nonGroupEnv r env grp - | otherwise = nonGroupEnv r env ((x, y):grp) - nonGroupEnv ((x, y):r) env grp = nonGroupEnv r (M.insert x y env) grp - -groupEnv :: Gen -> Set Id -> IdMap -> [(Id, Group)] -> [(Id, Group)] -> GenEnv -groupEnv g v env grp [] = - (g, Env (v, foldl (\env (x, y) -> M.insert x (G y) env) env grp)) -groupEnv g v env grp ((x, t):map) - | M.lookup x t /= Just 1 = groupEnv g v env grp map - | otherwise = - let (t0, t1) = partition M.empty (mul t (M.singleton x (-1))) v in - case matchGroup (group t0) (group t1) S.empty g of - Nothing -> groupEnv g v env grp map - Just (v', g', subst) -> - let grp' = L.delete (x, t) grp - grp'' = L.map (\(x, t) -> (x, groupSubst subst t)) grp' in - groupEnv g' (S.union v' v) env grp'' grp'' - --- Specialize an environment by mapping the generated variables to one. -specialize :: Env -> Env -specialize (Env (v, r)) = - Env (S.empty, M.foldrWithKey f M.empty r) - where - f x t r = M.insert x (instantiate special t) r - -- Environment mapping generated variables to one - special = Env (S.empty, S.fold g M.empty v) - g x r = M.insert x (G M.empty) r - --- Cast an environment into a substitution by filtering out trivial --- bindings. - -substitution :: Env -> Subst -substitution (Env (_, r)) = - Subst $ M.filterWithKey nonTrivialBinding r - --- Add type information to an environment, and return it as a list of --- associations. - -reify :: [Term] -> Env -> [(Term, Term)] -reify domain (Env (_, env)) = - map (loop domain) $ M.assocs env - where - loop [] (x, _) = - error $ "Algebra.reify: variable missing from domain " ++ idName x - loop (I x : _) (y, t) - | x == y = (I x, t) - loop (F Text [I x] : _) (y, t) - | x == y = (F Text [I x], F Text [t]) - loop (F Data [I x] : _) (y, t) - | x == y = (F Data [I x], F Data [t]) - loop (F Name [I x] : _) (y, t) - | x == y = (F Name [I x], F Name [t]) - loop (F Skey [I x] : _) (y, t) - | x == y = (F Skey [I x], F Skey [t]) - loop (F Akey [I x] : _) (y, t) - | x == y = (F Akey [I x], F Akey [t]) - loop (F Base [I x] : _) (y, t) - | x == y = (F Base [I x], F Base [t]) - loop (G x : _) (y, G t) - | isGroupVar x && varId (G x) == y = (G x, G t) - loop (_ : domain) pair = loop domain pair - --- Ensure the range of an environment contains only variables and that --- the environment is injective. -matchRenaming :: GenEnv -> Bool -matchRenaming (gen, Env (v, e)) = - nonGrp S.empty (M.elems e) && - groupMatchRenaming v gen (M.foldrWithKey grp M.empty e) - where - nonGrp _ [] = True - nonGrp s (I x:e) = - not (S.member x s) && nonGrp (S.insert x s) e - nonGrp s (G _:e) = nonGrp s e -- Check group bindings elsewhere - nonGrp _ _ = False - grp x (G t) map = M.insert x t map - grp _ _ map = map - -groupMatchRenaming :: Set Id -> Gen -> Map Id Group -> Bool -groupMatchRenaming v gen map = - loop S.empty $ M.elems map - where - loop _ [] = True - loop s (t:ge) - | M.null t = False - | isGroupVar t = - let x = varId (G t) in - not (S.member x s) && loop (S.insert x s) ge - | otherwise = any (groupMatchElim v gen map t) (M.assocs t) - -groupMatchElim :: Set Id -> Gen -> Map Id Group -> Group -> (Id, Int) -> Bool -groupMatchElim v gen ge t (x, 1) = - let (t0, t1) = partition M.empty (mul t (M.singleton x (-1))) v in - case matchGroup (group t0) (group t1) S.empty gen of - Nothing -> False - Just (v', gen', subst) -> - groupMatchRenaming (S.union v' v) gen' $ M.map (groupSubst subst) ge -groupMatchElim _ _ _ _ _ = False - -instance C.Env Term Gen Subst Env where - emptyEnv = emptyEnv - instantiate = instantiate - match t t' e = maybe [] (: []) $ match t t' e - identityEnvFor e ts = maybe [] (: []) $ identityEnvFor e ts - specialize = specialize - substitution = substitution - reify = reify - matchRenaming = matchRenaming - --- Term specific loading functions - -loadVars :: Monad m => Gen -> [SExpr Pos] -> m (Gen, [Term]) -loadVars gen sexprs = - do - pairs <- mapM loadVarPair sexprs - (g, vars) <- foldM loadVar (gen, []) (concat pairs) - return (g, reverse vars) - -loadVarPair :: Monad m => SExpr Pos -> m [(SExpr Pos, SExpr Pos)] -loadVarPair (L _ (x:xs)) = - let (t:vs) = reverse (x:xs) in - return [(v,t) | v <- reverse vs] -loadVarPair x = fail (shows (annotation x) "Bad variable declaration") - -loadVar :: Monad m => (Gen, [Term]) -> (SExpr Pos, SExpr Pos) -> - m (Gen, [Term]) -loadVar (gen, vars) (S pos name, S pos' sort) = - case loadLookup pos vars name of - Right _ -> - fail (shows pos "Duplicate variable declaration for " ++ name) - Left _ -> - do - let (gen', x) = freshId gen name - p <- mkVar x - return (gen', p : vars) - where - mkVar x = - let t = I x in - case sort of - "mesg" -> return t - "text" -> return $ F Text [t] - "data" -> return $ F Data [t] - "name" -> return $ F Name [t] - "skey" -> return $ F Skey [t] - "akey" -> return $ F Akey [t] - "base" -> return $ F Base [t] - "expn" -> return $ groupVar x - _ -> fail (shows pos' "Sort " ++ sort ++ " not recognized") -loadVar _ (x,_) = fail (shows (annotation x) "Bad variable syntax") - -loadLookup :: Pos -> [Term] -> String -> Either String Term -loadLookup pos [] name = Left (shows pos $ "Identifier " ++ name ++ " unknown") -loadLookup pos (t : u) name = - let name' = idName (varId t) in - if name' == name then Right t else loadLookup pos u name - -loadLookupName :: Monad m => Pos -> [Term] -> String -> m Term -loadLookupName pos vars name = - either fail f (loadLookup pos vars name) - where - f t@(F Name [I _]) = return t - f _ = fail (shows pos $ "Expecting " ++ name ++ " to be a name") - -loadLookupAkey :: Monad m => Pos -> [Term] -> String -> m Term -loadLookupAkey pos vars name = - either fail f (loadLookup pos vars name) - where - f t@(F Akey [I _]) = return t - f _ = fail (shows pos $ "Expecting " ++ name ++ " to be an akey") - --- Load term and check that it is well-formed. -loadTerm :: Monad m => [Term] -> SExpr Pos -> m Term -loadTerm vars (S pos s) = - either fail return (loadLookup pos vars s) -loadTerm _ (Q _ t) = - return (C t) -loadTerm vars (L pos (S _ s : l)) = - case lookup s loadDispatch of - Nothing -> fail (shows pos "Keyword " ++ s ++ " unknown") - Just f -> f pos vars l -loadTerm _ x = fail (shows (annotation x) "Malformed term") - -type LoadFunction m = Pos -> [Term] -> [SExpr Pos] -> m Term - -loadDispatch :: Monad m => [(String, LoadFunction m)] -loadDispatch = - [("pubk", loadPubk) - ,("privk", loadPrivk) - ,("invk", loadInvk) - ,("ltk", loadLtk) - ,("gen", loadGen) - ,("exp", loadExp) - ,("one", loadOne) - ,("rec", loadRec) - ,("mul", loadMul) - ,("cat", loadCat) - ,("enc", loadEnc) - ] - --- Atom constructors: pubk privk invk ltk - -loadPubk :: Monad m => LoadFunction m -loadPubk _ vars [S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Pubk [I $ varId t]] -loadPubk _ vars [Q _ c, S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Pubk [C c, I $ varId t]] -loadPubk pos _ _ = fail (shows pos "Malformed pubk") - -loadPrivk :: Monad m => LoadFunction m -loadPrivk _ vars [S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Invk [F Pubk [I $ varId t]]] -loadPrivk _ vars [Q _ c, S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Invk [F Pubk [C c, I $ varId t]]] -loadPrivk pos _ _ = fail (shows pos "Malformed privk") - -loadInvk :: Monad m => LoadFunction m -loadInvk _ vars [S pos s] = - do - t <- loadLookupAkey pos vars s - return $ F Akey [F Invk [I $ varId t]] -loadInvk pos _ _ = fail (shows pos "Malformed invk") - -loadLtk :: Monad m => LoadFunction m -loadLtk _ vars [S pos s, S pos' s'] = - do - t <- loadLookupName pos vars s - t' <- loadLookupName pos' vars s' - return $ F Skey [F Ltk [I $ varId t, I $ varId t']] -loadLtk pos _ _ = fail (shows pos "Malformed ltk") - --- Base and exponents - -loadGen :: Monad m => LoadFunction m -loadGen _ _ [] = - return $ F Base [F Genr []] -loadGen pos _ _ = fail (shows pos "Malformed gen") - -loadExp :: Monad m => LoadFunction m -loadExp _ vars [x, x'] = - do - t <- loadBase vars x - t' <- loadExpn vars x' - return $ F Base [idSubst emptyIdMap $ F Exp [t, G t']] -loadExp pos _ _ = fail (shows pos "Malformed exp") - -loadBase :: Monad m => [Term] -> SExpr Pos -> m Term -loadBase vars x = - do - t <- loadTerm vars x - case t of - F Base [t] -> return t - _ -> fail (shows (annotation x) "Malformed base") - -loadExpn :: Monad m => [Term] -> SExpr Pos -> m Group -loadExpn vars x = - do - t <- loadTerm vars x - case t of - G t -> return t - _ -> fail (shows (annotation x) "Malformed expn") - -loadOne :: Monad m => LoadFunction m -loadOne _ _ [] = - return $ G M.empty -loadOne pos _ _ = fail (shows pos "Malformed one") - -loadRec :: Monad m => LoadFunction m -loadRec _ vars [x] = - do - t <- loadExpn vars x - return $ G $ invert t -loadRec pos _ _ = fail (shows pos "Malformed rec") - -loadMul :: Monad m => LoadFunction m -loadMul _ vars xs = - do - t <- foldM f M.empty xs - return $ G t - where - f acc x = - do - t <- loadExpn vars x - return $ mul t acc - --- Term constructors: cat enc - -loadCat :: Monad m => LoadFunction m -loadCat _ vars (l : ls) = - do - ts <- mapM (loadTerm vars) (l : ls) - return $ foldr1 (\a b -> F Cat [a, b]) ts -loadCat pos _ _ = fail (shows pos "Malformed cat") - -loadEnc :: Monad m => LoadFunction m -loadEnc pos vars (l : l' : ls) = - do - let (butLast, last) = splitLast l (l' : ls) - t <- loadCat pos vars butLast - t' <- loadTerm vars last - return $ F Enc [t, t'] -loadEnc pos _ _ = fail (shows pos "Malformed enc") - -splitLast :: a -> [a] -> ([a], a) -splitLast x xs = - loop [] x xs - where - loop z x [] = (reverse z, x) - loop z x (y : ys) = loop (x : z) y ys - --- Term specific displaying functions - -newtype Context = Context [(Id, String)] deriving Show - -displayVars :: Context -> [Term] -> [SExpr ()] -displayVars _ [] = [] -displayVars ctx vars = - let (v,t):pairs = map (displayVar ctx) vars in - loop t [v] pairs - where - loop t vs [] = [L () (reverse (t:vs))] - loop t vs ((v',t'):xs) - | t == t' = loop t (v':vs) xs - | otherwise = L () (reverse (t:vs)):loop t' [v'] xs - -displayVar :: Context -> Term -> (SExpr (), SExpr ()) -displayVar ctx (I x) = displaySortId "mesg" ctx x -displayVar ctx (F Text [I x]) = displaySortId "text" ctx x -displayVar ctx (F Data [I x]) = displaySortId "data" ctx x -displayVar ctx (F Name [I x]) = displaySortId "name" ctx x -displayVar ctx (F Skey [I x]) = displaySortId "skey" ctx x -displayVar ctx (F Akey [I x]) = displaySortId "akey" ctx x -displayVar ctx (F Base [I x]) = displaySortId "base" ctx x -displayVar ctx t@(G x) - | isGroupVar x = displaySortId "expn" ctx (varId t) -displayVar _ _ = - error "Algebra.displayVar: term not a variable with its sort" - -displaySortId :: String -> Context -> Id -> (SExpr (), SExpr ()) -displaySortId sort ctx x = (displayId ctx x, S () sort) - -displayId :: Context -> Id -> SExpr () -displayId (Context ctx) x = - case lookup x ctx of - Nothing -> - let msg = idName x ++ " in a display context" in - error $ "Algebra.displayId: Cannot find variable " ++ msg - Just name -> S () name - -displayTerm :: Context -> Term -> SExpr () -displayTerm ctx (I x) = displayId ctx x -displayTerm ctx (F Text [I x]) = displayId ctx x -displayTerm ctx (F Data [I x]) = displayId ctx x -displayTerm ctx (F Name [I x]) = displayId ctx x -displayTerm ctx (F Skey [I x]) = displayId ctx x -displayTerm ctx (F Skey [F Ltk [I x, I y]]) = - L () [S () "ltk", displayId ctx x, displayId ctx y] -displayTerm ctx (F Akey [t]) = - case t of - I x -> displayId ctx x - F Invk [I x] -> L () [S () "invk", displayId ctx x] - F Pubk [I x] -> L () [S () "pubk", displayId ctx x] - F Pubk [C c, I x] -> L () [S () "pubk", Q () c, displayId ctx x] - F Invk [F Pubk [I x]] -> L () [S () "privk", displayId ctx x] - F Invk [F Pubk [C c, I x]] -> - L () [S () "privk", Q () c, displayId ctx x] - _ -> error ("Algebra.displayAkey: Bad term " ++ show t) -displayTerm ctx (F Base [t]) = - displayBase t - where - displayBase (I x) = displayId ctx x - displayBase (F Genr []) = - L () [S () "gen"] - displayBase (F Exp [t0, G t1]) = - L () [S () "exp", displayBase t0, displayTerm ctx (G t1)] - displayBase t = error ("Algebra.displayBase: Bad term " ++ show t) -displayTerm ctx (G t) = - displayExpn t - where - displayExpn t - | M.null t = L () [S () "one"] - | otherwise = - case factors t of - [f] -> displayFactor f - fs -> L () (S () "mul" : map displayFactor fs) - displayFactor (x, n) - | n >= 0 = displayId ctx x - | otherwise = L () [S () "rec", displayId ctx x] -displayTerm _ (C t) = Q () t -displayTerm ctx (F Cat [t0, t1]) = - L () (S () "cat" : displayTerm ctx t0 : displayList ctx t1) -displayTerm ctx (F Enc [t0, t1]) = - L () (S () "enc" : displayEnc ctx t0 t1) -displayTerm _ t = error ("Algebra.displayTerm: Bad term " ++ show t) - -displayList :: Context -> Term -> [SExpr ()] -displayList ctx (F Cat [t0, t1]) = displayTerm ctx t0 : displayList ctx t1 -displayList ctx t = [displayTerm ctx t] - -displayEnc :: Context -> Term -> Term -> [SExpr ()] -displayEnc ctx (F Cat [t0, t1]) t = displayTerm ctx t0 : displayEnc ctx t1 t -displayEnc ctx t0 t1 = [displayTerm ctx t0, displayTerm ctx t1] - -displayEnv :: Context -> Context -> Env -> [SExpr ()] -displayEnv ctx ctx' (Env (_, r)) = - map (\(x, t) -> L () [displayTerm ctx x, displayTerm ctx' t]) r' - where - r' = map (\(x, t) -> (I x, inferSort t)) $ M.assocs r - --- displaySubst c s displays a substitution s in context c, where some --- variables that occur in s might not be in c. Enough sort --- inference is performed so as to allow the extension of the context. -displaySubst :: Context -> Subst -> [SExpr ()] -displaySubst ctx s@(Subst r) = - map (\(x, t) -> L () [displayTerm ctx' x, displayTerm ctx' t]) r' - where - r' = map (\(x, t) -> (I x, inferSort (substitute s t))) $ M.assocs r - ctx' = foldl (\ctx (x, t) -> addToContext ctx [x, t]) ctx r' - -inferSort :: Term -> Term -inferSort t@(F Invk _) = F Akey [t] -inferSort t@(F Pubk _) = F Akey [t] -inferSort t@(F Ltk _) = F Skey [t] -inferSort t@(F Genr _) = F Base [t] -inferSort t@(F Exp _) = F Base [t] -inferSort t = t - -emptyContext :: Context -emptyContext = Context [] - --- Generate names for output renaming as necessary. --- Assumes the input is a list of term that are well-formed -addToContext :: Context -> [Term] -> Context -addToContext ctx u = - foldl (foldVars varContext) ctx u - -varContext :: Context -> Term -> Context -varContext ctx t = - let x = varId t - name = rootName $ idName x in - if hasId ctx x then - ctx - else - if hasName ctx name then - extendContext ctx x (genName ctx name) - else - extendContext ctx x name - -hasId :: Context -> Id -> Bool -hasId (Context ctx) id = - maybe False (const True) (lookup id ctx) - -hasName :: Context -> String -> Bool -hasName (Context ctx) name = - maybe False (const True) (L.find ((name ==) . snd) ctx) - -extendContext :: Context -> Id -> String -> Context -extendContext (Context ctx) x name = - Context $ (x, name) : ctx - -genName :: Context -> String -> String -genName ctx name = - loop 0 - where - root = '-' : reverse name - loop :: Int -> String - loop n = - let name' = revapp root (show n) in - if hasName ctx name' then - loop (n + 1) - else - name' - revapp [] s = s - revapp (c : cs) s = revapp cs (c : s) - -rootName :: String -> String -rootName name = - noHyphen 0 name - where - noHyphen _ [] = name - noHyphen i (c : s) - | c == '-' = hyphen i (i + 1) s - | otherwise = noHyphen (i + 1) s - hyphen i _ [] = rootName $ take i name - hyphen i j (c : s) - | isDigit c = hyphen i (j + 1) s - | otherwise = noHyphen j (c : s) - -instance C.Context Term Gen Subst Env Context where - emptyContext = emptyContext - addToContext = addToContext - displayVars = displayVars - displayTerm = displayTerm - displayEnv = displayEnv - displaySubst = displaySubst +-- Diffie-Hellman Algebra implementation + +-- This module implements a version of Diffie-Hellman in which +-- exponents form a free Abelian group. It uses the basis elements as +-- atoms principle. + +-- Copyright (c) 2009, 2014 The MITRE Corporation +-- +-- This program is free software: you can redistribute it and/or +-- modify it under the terms of the BSD License as published by the +-- University of California. + +-------------------------------------------------------------------- + +-- The module implements a many-sorted algebra, but is used as an +-- order-sorted algebra. It exports a name, and the origin used to +-- generate variables. + +-- The Diffie-Hellman Order-Sorted Signature is + +-- Sorts: mesg, text, data, name, skey, akey, +-- string, base, expr, and expn +-- +-- Subsorts: text, data, name, skey, akey, +-- base, expr < mesg and expn < expr +-- +-- Operations: +-- cat : mesg X mesg -> mesg Pairing +-- enc : mesg X mesg -> mesg Encryption +-- hash : mesg -> mesg Hashing +-- string : mesg Tag constants +-- ltk : name X name -> skey Long term shared key +-- pubk : name -> akey Public key of principal +-- pubk : string X name -> akey Tagged public key of principal +-- invk : akey -> akey Inverse of asymmetric key +-- gen : base DH generator +-- exp : base X expr -> base Exponentiation +-- mul : expr X expr -> expr Group operation +-- rec : expr -> expr Group inverse +-- one : expr Group identity +-- +-- Atoms: messages of sort text, data, name, skey, akey, and expn, and +-- messages of the form (exp (gen) x) where x is of sort expn. + +-- A free Abelian group has a set of basis elements, and the sort expn +-- is the sort for basis elements. Limiting the atoms associated with +-- an exponent to basis elements is the basis elements as atoms +-- principle. This principle enables CPSA to correctly handle +-- origination assumptions. + +-- Variables of sort string are forbidden. + +-- The implementation exploits the isomorphism between order-sorted +-- algebras and many-sorted algebras by adding inclusion operations to +-- produce an equivalent Diffie-Hellman Many-Sorted Signature. There +-- is an inclusion operation for each subsort of mesg. Diffie-Hellman +-- exponents are handled specially using a canonical representation as +-- monomials. + +-- Sorts: mesg, text, data, name, skey, akey, +-- string, base, expr, and expn +-- +-- Operations: +-- cat : mesg X mesg -> mesg Pairing +-- enc : mesg X mesg -> mesg Encryption +-- hash : mesg -> mesg Hashing +-- string : mesg Tag constants +-- ltk : name X name -> skey Long term shared key +-- pubk : name -> akey Public key of principal +-- pubk : string X name -> akey Tagged public key of principal +-- invk : akey -> akey Inverse of asymmetric key +-- text : text -> mesg Sort text inclusion +-- data : data -> mesg Sort date inclusion +-- name : name -> mesg Sort name inclusion +-- skey : skey -> mesg Sort skey inclusion +-- akey : akey -> mesg Sort akey inclusion +-- base : base -> mesg Sort base inclusion +-- +-- A message of sort expr, a monomial, is represented by a map from +-- identifiers to descriptions. A description is a pair consisting +-- of a flag saying if the variable is of sort expn or expr, and a +-- non-zero integer. For t of sort expr, the monomial associated +-- with t is +-- +-- x1 ^ c1 * x2 ^ c2 * ... * xn ^ cn +-- +-- for all xi in the domain of t and t(xi) = (_, ci). + +-- In both algebras, invk(invk(t)) = t for all t of sort akey, +-- (exp h (one)) = h, (exp (exp h x) y) = (exp h (mul x y)), and +-- the Abelian group axioms hold. + +{-# LANGUAGE MultiParamTypeClasses #-} + +module CPSA.DiffieHellman.Algebra (name, origin) where + +import Control.Monad (foldM) +import qualified Data.List as L +import qualified Data.Set as S +import Data.Set (Set) +import qualified Data.Map as M +import Data.Map (Map) +import Data.Char (isDigit) +import qualified CPSA.Lib.CPSA as C +import CPSA.Lib.CPSA (SExpr(..), Pos, annotation) + +{-- Debugging support +import System.IO.Unsafe + +z :: Show a => a -> b -> b +z x y = unsafePerformIO (print x >> return y) + +zz :: Show a => a -> a +zz x = z x x + +zn :: Show a => a -> Maybe b -> Maybe b +zn x Nothing = z x Nothing +zn _ y = y + +zf :: Show a => a -> Bool -> Bool +zf x False = z x False +zf _ y = y + +zt :: Show a => a -> Bool -> Bool +zt x True = z x True +zt _ y = y +--} + +{- Export iUnify and iMatch for GHCi for debugging + +For this to work, you must install the package bytestring-handle from +Hackage and tell GHCi that it is not hidden on the command line or +within GHCi with: + +:set -package bytestring-handle + +-} + +{-- +import System.IO (Handle) +import Data.ByteString.Lazy.Char8 (pack) +import Data.ByteString.Handle +import Control.Exception (try) +import System.IO.Unsafe + +stringHandle :: String -> IO Handle +stringHandle s = readHandle False (pack s) + +stringPosHandle :: String -> IO C.PosHandle +stringPosHandle s = + do + h <- stringHandle s + C.posHandle "" h + +stringLoad :: String -> IO [SExpr Pos] +stringLoad s = + do + h <- stringPosHandle s + loop h [] + where + loop h xs = + do + x <- C.load h + case x of + Nothing -> + return $ reverse xs + Just x -> + loop h (x : xs) + +sLoad :: String -> [[SExpr Pos]] +sLoad s = + [unsafePerformIO $ stringLoad s] + +-- Test unification + +iUnify :: String -> String -> String -> [Subst] +iUnify vars t t' = + iRun unify emptySubst vars t t' + +-- Test matching + +iMatch :: String -> String -> String -> [Env] +iMatch vars t t' = + iRun match emptyEnv vars t t' + +iRun :: (Term -> Term -> (Gen, a) -> [(Gen, a)]) -> a -> + String -> String -> String -> [a] +iRun f mt vars t t' = + do + vars <- sLoad vars + [t] <- sLoad t + [t'] <- sLoad t' + (gen, vars) <- loadVars origin vars + t <- loadTerm vars t + t' <- loadTerm vars t' + (_, a) <- f t t' (gen, mt) + return a + +gRun :: Gen -> Term -> a -> a +gRun (Gen n) t a = + foldVars f a t + where + f a t = + case varId t of + Id (m, _) | m >= n -> error ("Bad gen " ++ show n) + _ -> a + +gMatch :: Term -> Term -> GenEnv -> [GenEnv] +gMatch t t' r@(g, _) = gRun g t' (match t t' r) + +gUnify :: Term -> Term -> GenSubst -> [GenSubst] +gUnify t t' r@(g, _) = gRun g (F Cat [t, t']) (unify t t' r) +--} + +name :: String +name = "diffie-hellman" + +-- An identifier + +newtype Id = Id (Integer, String) deriving Show + +-- The integer distinguishes an identifier, the string is for printing. + +instance Eq Id where + (Id (x, _)) == (Id (x', _)) = x == x' + +instance Ord Id where + compare (Id (x, _)) (Id (x', _)) = compare x x' + +idName :: Id -> String +idName (Id (_, name)) = name + +-- Counter used for generating fresh identifiers. + +newtype Gen = Gen (Integer) deriving Show + +origin :: Gen +origin = Gen (0) + +freshId :: Gen -> String -> (Gen, Id) +freshId (Gen (i)) name = (Gen (i + 1), Id (i, name)) + +cloneId :: Gen -> Id -> (Gen, Id) +cloneId gen x = freshId gen (idName x) + +-- A term in an Abelian group is a map from identifiers to pairs of +-- bools and non-zero integers. The boolean is true if the variable +-- is a basis element. + +type Coef = Int + +type Desc = (Bool, Coef) + +type Group = Map Id Desc + +isGroupVar :: Group -> Bool +isGroupVar t = + M.size t == 1 && snd (head (M.elems t)) == 1 + +isBasisVar :: Group -> Bool +isBasisVar t = + M.size t == 1 && head (M.elems t) == (True, 1) + +isExprVar :: Group -> Bool +isExprVar t = + M.size t == 1 && head (M.elems t) == (False, 1) + +-- Assumes isGroupVar t == True or isBasisVar t == True! +getGroupVar :: Group -> Id +getGroupVar x = head $ M.keys x + +-- Create group var as a basis element if be is true +groupVar :: Bool -> Id -> Term +groupVar be x = G $ M.singleton x (be, 1) + +dMapCoef :: (Coef -> Coef) -> Desc -> Desc +dMapCoef f (be, c) = (be, f c) + +invert :: Group -> Group +invert t = M.map (dMapCoef negate) t + +expg :: Group -> Int -> Group +expg _ 0 = M.empty +expg t 1 = t +expg t n = M.map (dMapCoef (n *)) t + +mul :: Group -> Group -> Group +mul t t' = + M.foldrWithKey f t' t -- Fold over the mappings in t + where + f x c t = -- Alter the mapping of + M.alter (g c) x t -- variable x in t + g c Nothing = -- Variable x not currently mapped + Just c -- so add a mapping + g (b, c) (Just (b', c')) -- Variable x maps to c' + | b /= b' = error "Algebra.mul: sort mismatch" + | c + c' == 0 = Nothing -- Delete the mapping + | otherwise = Just $ (b, c + c') -- Adjust the mapping + +-- Why not replace M.assocs with M.toList elsewhere? + +type Maplet = (Id, Desc) + +mMapCoef :: (Coef -> Coef) -> Maplet -> Maplet +mMapCoef f (x, (be, c)) = (x, (be, f c)) + +mInverse :: [Maplet] -> [Maplet] +mInverse maplets = map (mMapCoef negate) maplets + +isMapletNonzero :: Maplet -> Bool +isMapletNonzero (_, (_, c)) = c /= 0 + +group :: [Maplet] -> Group +group maplets = + M.fromList $ filter isMapletNonzero maplets + +-- Function symbols--see foldVar to see the arity of each symbol. +data Symbol + = Text -- Text atom + | Data -- Another text-like atom + | Name -- Principal atom + | Skey -- Symmetric key atom + | Base -- Base of an exponentiated atom + | Ltk -- Long term shared symmetric key + | Akey -- Asymmetric key atom + | Invk -- Inverse of asymmetric key + | Pubk -- Public asymmetric key of a principal + | Genr -- The generator constant for the group + | Exp -- Exponentiation function symbol + | Cat -- Term concatenation + | Enc -- Encryption + | Hash -- Hashing + deriving (Show, Eq, Ord, Enum, Bounded) + +-- A Diffie-Hellman Algebra Term + +data Term + = I !Id + | C !String + | F !Symbol ![Term] + | G !Group -- An exponent, an Abelian group + deriving Show + +equalTerm :: Term -> Term -> Bool +equalTerm (I x) (I y) = x == y +equalTerm (C c) (C c') = c == c' +equalTerm (F Invk [F Invk [t]]) t' = equalTerm t t' +equalTerm t (F Invk [F Invk [t']]) = equalTerm t t' +equalTerm (F Exp [t0, G t1]) t' | M.null t1 = equalTerm t0 t' +equalTerm t (F Exp [t0, G t1]) | M.null t1 = equalTerm t t0 +equalTerm (F Exp [F Exp [t, G t0], G t1]) t' = + equalTerm (F Exp [t, G (mul t0 t1)]) t' +equalTerm t (F Exp [F Exp [t', G t0], G t1]) = + equalTerm t (F Exp [t', G (mul t0 t1)]) +equalTerm (F s u) (F s' u') = + s == s' && equalTermLists u u' +equalTerm (G t) (G t') = t == t' +equalTerm _ _ = False + +equalTermLists :: [Term] -> [Term] -> Bool +equalTermLists [] [] = True +equalTermLists (t : u) (t' : u') = + equalTerm t t' && equalTermLists u u' +equalTermLists _ _ = False + +instance Eq Term where + (==) = equalTerm + +-- Term comparison respecting the axiom + +compareTerm :: Term -> Term -> Ordering +compareTerm (I x) (I y) = compare x y +compareTerm (C c) (C c') = compare c c' +compareTerm (F Invk [F Invk [t]]) t' = compareTerm t t' +compareTerm t (F Invk [F Invk [t']]) = compareTerm t t' +compareTerm (F Exp [t0, G t1]) t' | M.null t1 = compareTerm t0 t' +compareTerm t (F Exp [t0, G t1]) | M.null t1 = compareTerm t t0 +compareTerm (F Exp [F Exp [t, G t0], G t1]) t' = + compareTerm (F Exp [t, G (mul t0 t1)]) t' +compareTerm t (F Exp [F Exp [t', G t0], G t1]) = + compareTerm t (F Exp [t', G (mul t0 t1)]) +compareTerm (F s u) (F s' u') = + case compare s s' of + EQ -> compareTermLists u u' + o -> o +compareTerm (G t) (G t') = compare t t' +compareTerm (I _) (C _) = LT +compareTerm (C _) (I _) = GT +compareTerm (I _) (F _ _) = LT +compareTerm (F _ _) (I _) = GT +compareTerm (I _) (G _) = LT +compareTerm (G _) (I _) = GT +compareTerm (C _) (F _ _) = LT +compareTerm (F _ _) (C _) = GT +compareTerm (C _) (G _) = LT +compareTerm (G _) (C _) = GT +compareTerm (F _ _) (G _) = LT +compareTerm (G _) (F _ _) = GT + +compareTermLists :: [Term] -> [Term] -> Ordering +compareTermLists [] [] = EQ +compareTermLists (t : u) (t' : u') = + case compareTerm t t' of + EQ -> compareTermLists u u' + o -> o +compareTermLists [] _ = LT +compareTermLists _ [] = GT + +instance Ord Term where + compare = compareTerm + +-- Basic terms are introduced by defining a function used to decide if +-- a term is well-formed. The context of an occurrence of an identifier +-- determines its sort. A term that contains just an identifier and its +-- sort information is called a variable. The sort of a variable is +-- one of mesg, text, data, name, skey, akey, base, expr, or expn. + +-- Terms that represent variables. +isVar :: Term -> Bool +isVar (I _) = True -- Sort: mesg +isVar (F s [I _]) = + -- Sorts: text, data, name, skey, and akey + s == Text || s == Data || s == Name || s == Skey || s == Akey || s == Base +isVar (G x) = isGroupVar x +isVar _ = False + +-- Extract the identifier from a variable +varId :: Term -> Id +varId (I x) = x +varId (F Text [I x]) = x +varId (F Data [I x]) = x +varId (F Name [I x]) = x +varId (F Skey [I x]) = x +varId (F Akey [I x]) = x +varId (F Base [I x]) = x +varId (G x) | isGroupVar x = getGroupVar x +varId _ = error "Algebra.varId: term not a variable with its sort" + +isAcquiredVar :: Term -> Bool +isAcquiredVar (I _) = True +isAcquiredVar (F Base [I _]) = True +isAcquiredVar (G x) = isExprVar x +isAcquiredVar _ = False + +-- A list of terms are well-formed if each one has the correct +-- structure and every occurrence of an identifier in a term has the +-- same sort. Variable environments are used to check the sort +-- condition. It maps an identifier to a variable that contains the +-- identifier. + +-- termsWellFormed u ensures all terms in u use each identifier at the +-- same sort, and makes sure every term has the correct structure. +termsWellFormed :: [Term] -> Bool +termsWellFormed u = + loop emptyVarEnv u + where + loop _ [] = True + loop env (t : u) = + case termWellFormed env t of + Nothing -> False + Just env' -> loop env' u + +newtype VarEnv = VarEnv (Map Id Term) deriving Show + +emptyVarEnv :: VarEnv +emptyVarEnv = VarEnv M.empty + +-- Check the structure and sort condition. + +termWellFormed :: VarEnv -> Term -> Maybe VarEnv +termWellFormed xts t@(I x) = + extendVarEnv xts x t -- Mesg variable +termWellFormed xts t@(F Text [I x]) = + extendVarEnv xts x t -- Text variable +termWellFormed xts t@(F Data [I x]) = + extendVarEnv xts x t -- Data variable +termWellFormed xts t@(F Name [I x]) = + extendVarEnv xts x t -- Name variable +termWellFormed xts t@(F Skey [I x]) = + extendVarEnv xts x t -- Symmetric key variable +termWellFormed xts (F Skey [F Ltk [I x, I y]]) = + -- Long term shared symmetric key + doubleTermWellFormed xts (F Name [I x]) (F Name [I y]) +termWellFormed xts (F Akey [t]) = -- Asymmetric key terms + case t of + I x -> extendVarEnv xts x (F Akey [I x]) + F Invk [I x] -> extendVarEnv xts x (F Akey [I x]) + F Pubk [I x] -> extendVarEnv xts x (F Name [I x]) + F Pubk [C _, I x] -> extendVarEnv xts x (F Name [I x]) + F Invk [F Pubk [I x]] -> extendVarEnv xts x (F Name [I x]) + F Invk [F Pubk [C _, I x]] -> extendVarEnv xts x (F Name [I x]) + _ -> Nothing +termWellFormed xts (F Base [t]) = + baseVarEnv xts t + where + baseVarEnv xts t@(I x) = + extendVarEnv xts x (F Base [t]) + baseVarEnv xts (F Genr []) = + Just xts + baseVarEnv xts (F Exp [t0, G t1]) = + do + xts <- baseVarEnv xts t0 + termWellFormed xts (G t1) + baseVarEnv _ _ = Nothing +termWellFormed xts (G t) = + foldM exprVarEnv xts (M.assocs t) + where + exprVarEnv xts (x, (be, _)) = + extendVarEnv xts x (groupVar be x) +termWellFormed xts (C _) = + Just xts -- Tags +termWellFormed xts (F Cat [t0, t1]) = + doubleTermWellFormed xts t0 t1 -- Concatenation +termWellFormed xts (F Enc [t0, t1]) = + doubleTermWellFormed xts t0 t1 -- Encryption +termWellFormed xts (F Hash [t]) = + termWellFormed xts t -- Hashing +termWellFormed _ _ = Nothing + +-- Extend when sorts agree +extendVarEnv :: VarEnv -> Id -> Term -> Maybe VarEnv +extendVarEnv (VarEnv env) x t = + case M.lookup x env of + Nothing -> Just $ VarEnv $ M.insert x t env + Just t' -> if t == t' then Just (VarEnv env) else Nothing + +doubleTermWellFormed :: VarEnv -> Term -> Term -> Maybe VarEnv +doubleTermWellFormed xts t0 t1 = + do + xts <- termWellFormed xts t0 + termWellFormed xts t1 + +-- Atoms are terms the adversary can create modulo origination +-- assumptions. +isAtom :: Term -> Bool +isAtom (I _) = False +isAtom (C _) = False +isAtom (F Base [F Exp [F Genr [], G x]]) = isBasisVar x +isAtom (F s _) = + s == Text || s == Data || s == Name || s == Skey || s == Akey +isAtom (G x) = isBasisVar x + +-- Does a term occur in another term? + +-- This function is always called with a variable that answers true to +-- isAcquiredVar as its first argument, so the first case never gets used. +occursIn :: Term -> Term -> Bool +occursIn (G t) (G t') = + t == t' +occursIn t t' = + t == t' || + case t' of + F _ u -> any (occursIn t) u + _ -> False + +-- Fold f through a term applying it to each variable in the term. +foldVars :: (a -> Term -> a) -> a -> Term -> a +foldVars f acc t@(I _) = f acc t -- Mesg variable +foldVars f acc t@(F Text [I _]) = f acc t -- Text variable +foldVars f acc t@(F Data [I _]) = f acc t -- Data variable +foldVars f acc t@(F Name [I _]) = f acc t -- Name variable +foldVars f acc t@(F Skey [I _]) = + f acc t -- Symmetric key variable +foldVars f acc (F Skey [F Ltk [I x, I y]]) = + -- Long term shared symmetric key + f (f acc (F Name [I x])) (F Name [I y]) +foldVars f acc t@(F Akey [I _]) = f acc t -- Asymmetric keys +foldVars f acc (F Akey [F Invk [I x]]) = f acc (F Akey [I x]) +foldVars f acc (F Akey [F Pubk [I x]]) = f acc (F Name [I x]) +foldVars f acc (F Akey [F Pubk [C _, I x]]) = f acc (F Name [I x]) +foldVars f acc (F Akey [F Invk [F Pubk [I x]]]) = f acc (F Name [I x]) +foldVars f acc (F Akey [F Invk [F Pubk [C _, I x]]]) = f acc (F Name [I x]) +foldVars f acc (F Base [t]) = + baseAddVars acc t + where + baseAddVars acc t@(I _) = + f acc (F Base [t]) + baseAddVars acc (F Genr []) = + acc + baseAddVars acc (F Exp [t0, G t1]) = + foldVars f (baseAddVars acc t0) (G t1) + baseAddVars _ _ = error "Algebra.foldVars: Bad term" +foldVars f acc (G t) = + M.foldlWithKey exprAddVars acc t + where + exprAddVars acc x (be, _) = + f acc (groupVar be x) +foldVars _ acc (C _) = acc -- Tags +foldVars f acc (F Cat [t0, t1]) = -- Concatenation + foldVars f (foldVars f acc t0) t1 +foldVars f acc (F Enc [t0, t1]) = -- Encryption + foldVars f (foldVars f acc t0) t1 +foldVars f acc (F Hash [t]) = -- Hashing + foldVars f acc t +foldVars _ _ t = error $ "Algebra.foldVars: Bad term " ++ show t + +-- Fold f through a term applying it to each term that is carried by the term. +foldCarriedTerms :: (a -> Term -> a) -> a -> Term -> a +foldCarriedTerms f acc t@(F Cat [t0, t1]) = -- Concatenation + foldCarriedTerms f (foldCarriedTerms f (f acc t) t0) t1 +foldCarriedTerms f acc t@(F Enc [t0, _]) = -- Encryption + foldCarriedTerms f (f acc t) t0 +foldCarriedTerms f acc t = f acc t -- atoms and tags + +-- Is a term carried by another term? +carriedBy :: Term -> Term -> Bool +carriedBy t t' = + t == t' || + case t' of + F Cat [t0, t1] -> carriedBy t t0 || carriedBy t t1 + F Enc [t0, _] -> carriedBy t t0 + _ -> False + +-- The key used to decrypt an encrypted term, otherwise Nothing. +decryptionKey :: Term -> Maybe Term +decryptionKey (F Enc [_, t]) = Just (inv t) +decryptionKey _ = Nothing + +buildable :: Set Term -> Set Term -> Term -> Bool +buildable knowns unguessable term = + ba term + where + ba (I _) = True -- A mesg sorted variable is always buildable + ba (C _) = True -- So is a tag + ba (F Cat [t0, t1]) = + ba t0 && ba t1 + ba t@(F Enc [t0, t1]) = + S.member t knowns || ba t0 && ba t1 + ba t@(F Hash [t1]) = + S.member t knowns || ba t1 + ba t@(F Base [t']) + | S.member t knowns || bb t' = True + ba t@(G t') + | hasFluff unguessable t' = -- Expunge guessable part + ba (defluff unguessable t') + | S.member t knowns || M.null t' = True -- t known or is one + ba t = isAtom t && S.notMember t unguessable + -- Buildable base term + bb (I _) = True -- A variable of sort base is always buildable + bb (F Genr []) = True -- and so is the generator + bb t@(F Exp [t0, G t1]) + | hasFluff unguessable t1 = -- Expunge guessable part + bb (F Exp [t0, defluff unguessable t1]) + | otherwise = -- t known or base and exponent buildable + S.member (F Base [t]) knowns || ba (G t1) && ba t0 + bb (_) = False + +-- Compute the decomposition given some known terms and some unguessable +-- atoms. The code is quite tricky. It iterates until the known +-- terms don't change. The known terms ends up with all the +-- encryptions that are known. +decompose :: Set Term -> Set Term -> (Set Term, Set Term) +decompose knowns unguessable = + loop unguessable knowns S.empty [] + where + loop unguessable knowns old [] + | old == knowns = (knowns, unguessable) -- Done + | otherwise = loop unguessable knowns knowns (S.elems knowns) + loop unguessable knowns old (t@(F Cat _) : todo) = + loop unguessable (decat t (S.delete t knowns)) old todo + loop unguessable knowns old ((F Enc [t0, t1]) : todo) + | buildable knowns unguessable (inv t1) = -- Add plaintext + loop unguessable (decat t0 knowns) old todo + | otherwise = loop unguessable knowns old todo + loop unguessable knowns old (G t : todo) + | M.null t = + loop unguessable (S.delete (G t) knowns) old todo + | hasFluff unguessable t = + loop unguessable + (S.insert (defluff unguessable t) (S.delete (G t) knowns)) + old todo + loop unguessable knowns old (t@(F Base [F Exp [t0, G t1]]) : todo) + | M.null t1 = + loop unguessable + (S.insert (F Base [t0]) (S.delete t knowns)) + old todo + | hasFluff unguessable t1 = -- Expunge guessable part + loop unguessable + (S.insert (F Base [F Exp [t0, t1']]) (S.delete t knowns)) + old todo + where + t1' = defluff unguessable t1 + loop unguessable knowns old (t : todo) + | isAtom t = + loop (S.delete t unguessable) (S.delete t knowns) old todo + | otherwise = loop unguessable knowns old todo + -- Decat + decat (F Cat [t0, t1]) s = decat t1 (decat t0 s) + decat t s = S.insert t s + +-- Inverts an asymmetric key +inv :: Term -> Term +inv (F Akey [F Invk [t]]) = F Akey [t] +inv (F Akey [t]) = F Akey [F Invk [t]] +inv (I _) = error "Algebra.inv: Cannot invert a variable of sort mesg" +inv t = t + +-- Does a group term have a variable of sort expr or a variable not in +-- the avoidance set a? +hasFluff :: Set Term -> Group -> Bool +hasFluff a t = + any f (M.assocs t) + where + f (x, d) = fluff a x d + +fluff :: Set Term -> Id -> Desc -> Bool +fluff a x (be, _) = not be || S.notMember (groupVar be x) a +-- fluff a x (be, _) = be && S.notMember (groupVar be x) a + +-- Remove fluff from a group term +defluff :: Set Term -> Group -> Term +defluff a t = + G $ M.filterWithKey (\x d -> not $ fluff a x d) t + +-- Extracts every encryption that is carried by a term along with its +-- encryption key. Note that a hash is treated as a kind of +-- encryption in which the term that is hashed is the encryption key. +encryptions :: Term -> [(Term, [Term])] +encryptions t = + reverse $ loop t [] + where + loop (F Cat [t, t']) acc = + loop t' (loop t acc) + loop t@(F Enc [t', t'']) acc = + loop t' (adjoin (t, [t'']) acc) + loop t@(F Hash [t']) acc = + adjoin (t, [t']) acc + -- loop t@(F Base [F Exp [F Genr [], G t']]) acc = + -- adjoin (t, basis t') acc + loop t@(F Base [F Exp [_, G t']]) acc = + adjoin (t, basis t') acc + loop _ acc = acc + adjoin x xs + | x `elem` xs = xs + | otherwise = x : xs + +-- The basis variables is a group term +basis :: Group -> [Term] +basis t = + [groupVar True x | (x, (be, _)) <- M.assocs t, be] + +-- Returns the encryptions that carry the target. If the target is +-- carried outside all encryptions, or is exposed because a decription +-- key is derivable, Nothing is returned. +protectors :: (Term -> Bool) -> Term -> Term -> Maybe [Term] +protectors derivable target source = + do + ts <- bare source S.empty + return $ S.elems ts + where + bare source _ + | source == target = Nothing + bare (F Cat [t, t']) acc = + maybe Nothing (bare t') (bare t acc) + bare t@(F Enc [t', key]) acc = + if target `carriedBy` t' then + if derivable (inv key) then + bare t' acc + else + Just (S.insert t acc) + else + Just acc + bare _ acc = Just acc + +-- FIX ME! Needs updating for Diffie-Hellman + +-- Support for data flow analysis of traces. A flow rule maps an +-- initial set of atoms and a set of available terms to sets of pairs +-- of the same sets. +type FlowRule = (Set Term, Set Term) -> Set (Set Term, Set Term) + +-- Combine flow rules sequentially. +comb :: FlowRule -> FlowRule -> FlowRule +comb f g x = + S.fold h S.empty (g x) + where + h a s = S.union (f a) s + +-- Analyze a term as a sent term. +outFlow :: Term -> FlowRule +outFlow t a@(_, available) + | S.member t available = S.singleton a +outFlow (I _) _ = S.empty +outFlow (C _) a = S.singleton a +outFlow (F Cat [t0, t1]) a = -- Construct non-atoms + comb (outFlow t1) (outFlow t0) a +outFlow (F Enc [t0, t1]) a = + comb (outFlow t1) (outFlow t0) a +outFlow (F Hash [t]) a = + outFlow t a +outFlow t (initial, available) = -- Don't look inside atoms + S.singleton (S.insert t initial, S.insert t available) + +-- Analyze a term as a received term. +inFlow :: Term -> FlowRule +inFlow (C _) a = S.singleton a +inFlow (F Cat [t0, t1]) a = -- Try to receive components + S.union -- in both orders + (comb (inFlow t1) (inFlow t0) a) + (comb (inFlow t0) (inFlow t1) a) +inFlow t@(F Enc [t0, t1]) (initial, available) = + S.union -- Encryption can be built + (outFlow t (initial, available)) -- or decrypted + (comb (inFlow t0) (outFlow (inv t1)) a) + where -- Derive decryption key first + a = (initial, S.insert t available) +inFlow (F Hash [t0]) (initial, available) = + outFlow t0 (initial, available) +inFlow t (initial, available) = + S.singleton (initial, S.insert t available) + +instance C.Term Term where + isVar = isVar + isAcquiredVar = isAcquiredVar + isAtom = isAtom + termsWellFormed = termsWellFormed + occursIn = occursIn + foldVars = foldVars + foldCarriedTerms = foldCarriedTerms + carriedBy = carriedBy + decryptionKey = decryptionKey + decompose = decompose + buildable = buildable + encryptions = encryptions + protectors = protectors + outFlow = outFlow + inFlow = inFlow + loadTerm = loadTerm + +-- Places + +-- A place names a one subterm within a term. It is a list of +-- integers giving a path through a term to that named subterm. Each +-- integer in the list identifies the subterm in a function +-- application on the path to the named subterm. The integer is the +-- index of the subterm in the application's list of terms. + +-- The places and replace code fail to find the variable +-- (F Akey [I x]) in (F Akey [Invk [I x]]). + +newtype Place = Place [Int] deriving Show + +-- Returns the places a variable occurs within a term. +-- Returns no places for group variables. +places :: Term -> Term -> [Place] +places var source = + f [] [] source + where + f paths path source + | var == source = Place (reverse path) : paths + f paths path (F _ u) = + g paths path 0 u + f paths _ _ = paths + g paths _ _ [] = paths + g paths path i (t : u) = + g (f paths (i: path) t) path (i + 1) u + +-- Returns the places a term is carried by another term. +carriedPlaces :: Term -> Term -> [Place] +carriedPlaces target source = + f [] [] source + where + f paths path source + | target == source = Place (reverse path) : paths + f paths path (F Cat [t, t']) = + f (f paths (0 : path) t) (1 : path) t' + f paths path (F Enc [t, _]) = + f paths (0 : path) t + f paths _ _ = paths + +-- Replace a variable within a term at a given place. +replace :: Term -> Place -> Term -> Term +replace var (Place ints) source = + loop ints source + where + loop [] _ = var + loop (i : path) (F s u) = + F s (C.replaceNth (loop path (u !! i)) i u) + loop _ (G _) = error "Algebra.replace: Path to expr" + loop _ _ = error "Algebra.replace: Bad path to term" + +-- Return the ancestors of the term at the given place. +ancestors :: Term -> Place -> [Term] +ancestors source (Place ints) = + loop [] ints source + where + loop ts [] _ = ts + loop ts (i: path) t@(F _ u) = + loop (t : ts) path (u !! i) + loop _ _ _ = error "Algebra.ancestors: Bad path to term" + +instance C.Place Term Place where + places = places + carriedPlaces = carriedPlaces + replace = replace + ancestors = ancestors + +-- Rename the identifiers in a term. Gen keeps the state of the +-- renamer. (Question: should alist be replaced by a Map?) +clone :: Gen -> Term -> (Gen, Term) +clone gen t = + (gen', t') + where + (_, gen', t') = cloneTerm ([], gen) t + cloneTerm (alist, gen) t = + case t of -- The association list maps + I x -> -- identifiers to identifier. + case lookup x alist of + Just y -> (alist, gen, I y) + Nothing -> + let (gen', y) = cloneId gen x in + ((x, y) : alist, gen', I y) + C c -> (alist, gen, C c) + F sym u -> + let (alist', gen', u') = + foldl cloneTermList (alist, gen, []) u in + (alist', gen', F sym $ reverse u') + G t -> + let (alist', gen', ts) = + M.foldlWithKey cloneGroupList (alist, gen, []) t in + (alist', gen', G $ group ts) + cloneTermList (alist, gen, u) t = + let (alist', gen', t') = cloneTerm (alist, gen) t in + (alist', gen', t' : u) + cloneGroupList (alist, gen, ts) x (be, c) = + case lookup x alist of + Just y -> (alist, gen, (y, (be, c)) : ts) + Nothing -> + let (gen', y) = cloneId gen x in + ((x, y) : alist, gen', (y, (be, c)) : ts) + +instance C.Gen Term Gen where + origin = origin + clone = clone + loadVars = loadVars + +-- Functions used in both unification and matching + +type IdMap = Map Id Term + +emptyIdMap :: IdMap +emptyIdMap = M.empty + +-- Apply a substitution to a term +idSubst :: IdMap -> Term -> Term +idSubst subst (I x) = + M.findWithDefault (I x) x subst +idSubst _ t@(C _) = t +idSubst subst (F Invk [t]) = + case idSubst subst t of + F Invk [t] -> t -- (invk (invk x)) = x + t -> F Invk [t] +idSubst subst (F Exp [t0, G t1]) = + case idSubst subst t0 of -- (exp (exp g x) y) = (exp g (mul x y)) + F Exp [t0', G t1'] -> + case mul t1' $ groupSubst subst t1 of + t2 | M.null t2 -> t0' + | otherwise -> F Exp [t0', G t2] + t -> expSubst subst t t1 +idSubst subst (F s u) = + F s (map (idSubst subst) u) +idSubst subst (G t) = + G $ groupSubst subst t + +expSubst :: IdMap -> Term -> Group -> Term +expSubst subst t0 t1 = + case groupSubst subst t1 of + t1' | M.null t1' -> t0 -- (exp g (one)) = g + | otherwise -> F Exp [t0, G t1'] + +groupSubst :: IdMap -> Group -> Group +groupSubst subst t = + M.foldrWithKey f M.empty t + where + f x (be, c) t = + mul (expg (groupLookup subst be x) c) t + +groupLookup :: IdMap -> Bool -> Id -> Group +groupLookup subst be x = + case M.findWithDefault (groupVar be x) x subst of + G t -> t + w -> error ("Algebra.groupLookup: Bad substitution: " ++ + show x ++ " -> " ++ show w) + +showMap :: (Show a, Show b) => Map a b -> ShowS +showMap m = + showAssocs (M.assocs m) + where + showAssocs [] = id + showAssocs ((x,y):m) = + showString "\n " . shows x . showString " -> " . + shows y . showAssocs m + +-- Unification and substitution + +-- The rewrite rules used are: +-- +-- (vars (h base) (x y expr)) +-- +-- 1. ((exp h x) y) ==> (exp h (mul x y)) +-- 2. (exp h (one)) ==> h +-- 3. unify((exp h x), (exp h y), s) ==> +-- unify(x, y, s) +-- 4 unify((exp h x), (exp (gen) y), s) ==> +-- unify(h, (exp gen (mul y (rec x))), s) +-- 5. unify((exp (gen) x), (exp h y), s) ==> +-- unify((exp h x), (exp (gen) y), s) + +newtype Subst = Subst IdMap deriving (Eq, Ord) + +instance Show Subst where + showsPrec _ (Subst s) = showString "Subst (" . showMap s . showChar ')' + +emptySubst :: Subst +emptySubst = Subst emptyIdMap + +-- Apply a substitution created by unification +substitute :: Subst -> Term -> Term +substitute (Subst s) t = + idSubst s t + +-- Composition of substitutions + +-- substitute (compose s0 s1) t = substitute s0 (substitute s1 t) + +-- 1. apply s0 to range of s1 to obtain s2; +-- 2. remove bindings is s0 where domains of s0 and s1 overlap to form s3; +-- 3. remove trivial bindings from s2 to form s4; and +-- 4. take the union of s4 and s3. + +compose :: Subst -> Subst -> Subst +compose (Subst s0) (Subst s1) = + let s2 = M.map (substitute (Subst s0)) s1 -- Step 1 + s4 = M.filterWithKey nonTrivialBinding s2 in -- Step 3 + Subst (M.union s4 s0) -- Steps 2 and 4, union is left-biased + +nonTrivialBinding :: Id -> Term -> Bool +nonTrivialBinding x (I y) = x /= y +nonTrivialBinding x (G y) | isGroupVar y = x /= getGroupVar y +nonTrivialBinding _ _ = True + +-- During unification, variables determined to be equal are collected +-- into an equivalence class. Multiple lookups of each variable in +-- the internal representation of a substitution finds the canonical +-- representive of the class. The chase function finds the current +-- canonical representitive. + +-- Get the canonical representative of equivalent identifiers making use +-- of this algebra's axiom. +chase :: Subst -> Term -> Term +chase (Subst s) (I x) = + case M.lookup x s of + Nothing -> I x + Just t -> chase (Subst s) t +chase s (F Invk [t]) = chaseInvk s t +chase s (F Exp [t0, G t1]) = chaseExp s t0 t1 +chase _ t = t + +chaseInvk :: Subst -> Term -> Term +chaseInvk (Subst s) (I x) = + case M.lookup x s of + Nothing -> F Invk [I x] + Just t -> chaseInvk (Subst s) t +chaseInvk s (F Invk [t]) = chase s t +chaseInvk _ t = F Invk [t] + +chaseExp :: Subst -> Term -> Group -> Term +chaseExp s t0 t1 + | M.null t1 = chase s t0 +chaseExp s (I x) t1 = + case chase s (I x) of + F Exp [t0', G t1'] -> chaseExp s t0' (mul t1 t1') + t0 -> F Exp [t0, chaseGroup s t1] +chaseExp s (F Exp [t0', G t1']) t1 = + chaseExp s t0' (mul t1 t1') +chaseExp s t0 t1 = F Exp [t0, chaseGroup s t1] + +chaseGroup :: Subst -> Group -> Term +chaseGroup (Subst s) x = G $ groupSubst s x + +-- Does x occur in t? +occurs :: Id -> Term -> Bool +occurs x (I y) = x == y +occurs _ (C _) = False +occurs x (F _ u) = any (occurs x) u +occurs x (G t) = elem x (M.keys t) + +type GenSubst = (Gen, Subst) + +unifyChase :: Term -> Term -> GenSubst -> [GenSubst] +unifyChase t t' (g, s) = unifyTerms (chase s t) (chase s t') (g, s) + +unifyTerms :: Term -> Term -> GenSubst -> [GenSubst] +unifyTerms (I x) (I y) (g, Subst s) + | x == y = [(g, Subst s)] + | otherwise = [(g, Subst $ M.insert x (I y) s)] +unifyTerms (I x) t (g, Subst s) + | occurs x t = [] + | otherwise = [(g, Subst $ M.insert x t s)] +unifyTerms t (I x) s = unifyTerms (I x) t s +unifyTerms (C c) (C c') s + | c == c' = [s] + | otherwise = [] +unifyTerms (F Invk [I x]) (F Pubk [I y]) s = + unifyTerms (I x) (F Invk [F Pubk [I y]]) s +unifyTerms (F Invk [I x]) (F Pubk [C c, I y]) s = + unifyTerms (I x) (F Invk [F Pubk [C c, I y]]) s +unifyTerms (F Pubk [I x]) (F Invk [I y]) s = + unifyTerms (I y) (F Invk [F Pubk [I x]]) s +unifyTerms (F Pubk [C c, I x]) (F Invk [I y]) s = + unifyTerms (I y) (F Invk [F Pubk [C c, I x]]) s +unifyTerms (F Exp [t0, G t1]) (F Exp [t0', G t1']) s = + unifyExp t0 t1 t0' t1' s +unifyTerms (F sym u) (F sym' u') s + | sym == sym' = unifyTermLists u u' s + | otherwise = [] +unifyTerms (G t) (G t') s = unifyGroup t t' s +unifyTerms _ _ _ = [] + +unifyExp :: Term -> Group -> Term -> Group -> GenSubst -> [GenSubst] +unifyExp t0 t1 t0' t1' s + | t0 == t0' = unifyGroup t1 t1' s +unifyExp (I x) t1 (F Genr []) t1' (g, Subst s) + | t1 == t1' = + [(g, Subst $ M.insert x (F Genr []) s)] + | otherwise = + [(g, Subst (M.insert + x + (F Exp [F Genr [], G $ mul t1' (invert t1)]) + s))] +unifyExp (F Genr []) t1 (I x) t1' s = + unifyExp (I x) t1' (F Genr []) t1 s +unifyExp _ _ _ _ _ = [] + +unifyTermLists :: [Term] -> [Term] -> GenSubst -> [GenSubst] +unifyTermLists [] [] s = [s] +unifyTermLists (t : u) (t' : u') s = + do + s' <- unifyChase t t' s + unifyTermLists u u' s' +unifyTermLists _ _ _ = [] + +unifyGroup :: Group -> Group -> GenSubst -> [GenSubst] +unifyGroup t0 t1 (g, Subst s) = + do + let t = groupSubst s (mul t0 (invert t1)) + (_, g', s') <- matchGroup t M.empty S.empty g s + return (g', Subst s') + +-- The exported unifier converts the internal representation of a +-- substitution into the external form using chaseMap. + +unify :: Term -> Term -> GenSubst -> [GenSubst] +unify t t' s = + do + (g, s) <- unifyChase t t' s + return (g, chaseMap s) + +-- Apply the chasing version of substitution to the range of s. + +chaseMap :: Subst -> Subst +chaseMap (Subst s) = + Subst $ M.map (substChase (Subst s)) s + +-- A chasing version of substitution. + +substChase :: Subst -> Term -> Term +substChase subst t = + case chase subst t of + t@(I _) -> t + t@(C _) -> t + F Invk [t] -> + case substChase subst t of + F Invk [t] -> t -- Apply axiom + t -> F Invk [t] + F Exp [t0, G t1] -> + case substChase subst t0 of + F Exp [t0', G t1'] -> + case mul t1' $ groupChase subst t1 of + t2 | M.null t2 -> t0' + | otherwise -> F Exp [t0', G t2] + t -> expChase subst t t1 + F s u -> + F s (map (substChase subst) u) + G t -> G $ groupChase subst t + +expChase :: Subst -> Term -> Group -> Term +expChase subst t0 t1 = + case groupChase subst t1 of + t1' | M.null t1' -> t0 + | otherwise -> F Exp [t0, G t1'] + +groupChase :: Subst -> Group -> Group +groupChase (Subst subst) t = groupSubst subst t + +instance C.Subst Term Gen Subst where + emptySubst = emptySubst + substitute = substitute + unify = unify + compose = compose + +-- Matching and instantiation + +newtype Env = Env (Set Id, IdMap) deriving (Eq, Ord) + +instance Show Env where + showsPrec _ (Env (v, r)) = + showString "Env (\n " . shows v . + showChar ',' . showMap r . showChar ')' + +-- An environment may contain an explicit identity mapping, whereas a +-- substitution is erroneous if it has one. The set of variables +-- associated with a map is the variables in the range that were +-- generated by matching and should be treated as variables when using +-- unification to perform matching. The other variables in the range +-- are treated as constants. + +-- An environment contains an IdMap and the set of variables +-- generated while matching. + +emptyEnv :: Env +emptyEnv = Env (S.empty, emptyIdMap) + +-- Apply a substitution created my matching +instantiate :: Env -> Term -> Term +instantiate (Env (_, r)) t = idSubst r t + +-- Matching + +type GenEnv = (Gen, Env) + +-- The matcher has the property that when pattern P and term T match +-- then instantiate (match P T emptyEnv) P = T. +match :: Term -> Term -> GenEnv -> [GenEnv] +match (I x) t (g, Env (v, r)) = + case M.lookup x r of + Nothing -> [(g, Env (v, M.insert x t r))] + Just t' -> if t == t' then [(g, Env (v, r))] else [] +match (C c) (C c') r = if c == c' then [r] else [] +match (F Exp [t0, G t1]) (F Exp [t0', G t1']) r + = matchExp t0 t1 t0' t1' r +match (F s u) (F s' u') r + | s == s' = matchLists u u' r +match (F Invk [t]) t' r = + match t (F Invk [t']) r +match (G t) (G t') (g, Env (v, r)) = + do + (v', g', r') <- matchGroup t t' v g r + return (g', Env(v', r')) +match _ _ _ = [] + +matchExp :: Term -> Group -> Term -> Group -> GenEnv -> [GenEnv] +matchExp (I x) t1 t0' t1' r@(_, Env (_, e)) = + case M.lookup x e of + Just (F Exp [t0'', G t1'']) + | t0' == t0'' -> match (G t1) (G (mul t1' (invert t1''))) r + _ -> matchLists [I x, G t1] [t0', G t1'] r +matchExp (F Genr []) t1 t0' t1' r = + matchLists [F Genr [], G t1] [t0', G t1'] r +matchExp _ _ _ _ _ = error "Algebra.matchExp: Bad match term" + +matchLists :: [Term] -> [Term] -> GenEnv -> [GenEnv] +matchLists [] [] r = [r] +matchLists (t : u) (t' : u') r = + do + r' <- match t t' r + matchLists u u' r' +matchLists _ _ _ = [] + +-- Matching in a group + +-- t0 is the pattern +-- t1 is the target term +-- v is the set of previously freshly generated variables +-- g is the generator + +-- Returns complete set of unifiers. Each unifier include the set of +-- variables fresh generated and a generator. + +matchGroup :: Group -> Group -> Set Id -> Gen -> + IdMap -> [(Set Id, Gen, IdMap)] +matchGroup t0 t1 v g r = + let (t0', t1') = merge t0 t1 r -- Apply subst to LHS + (v', g', r') = genVars v g t0' r -- Gen vars for non-fresh vars + d = mkInitMatchDecis t1' in -- Ensure expns on RHS stay distinct + case partition (groupSubst r' t0') t1' v' of + ([], []) -> return (v', g', r') + ([], t) -> constSolve t v' g' r' d -- No variables of sort expr here + (t0, t1) -> solve t0 t1 v' g' r' d + +-- Apply subst to LHS and add results to RHS +merge :: Group -> Group -> IdMap -> (Group, Group) +merge t t' r = + (group t0, t0') + where + (t0, t0') = loop (M.assocs t) ([], t') + loop [] acc = acc + loop (p@(x, (_, c)) : t0) (t1, t1') = + case M.lookup x r of + Nothing -> loop t0 (p : t1, t1') + Just (G t) -> + loop t0 (t1, mul (expg t (negate c)) t1') + Just t -> + error $ "Algebra.merge: expecting an expr but got " ++ show t + +-- Generate vars for each non-fleshly generated vars +genVars :: Set Id -> Gen -> Group -> IdMap -> (Set Id, Gen, IdMap) +genVars v g t r = + M.foldlWithKey genVar (v, g, r) t + where + genVar (v, g, r) x (be, _) = + (S.insert x' v, g', M.insert x (groupVar be x') r) + where + (g', x') = cloneId g x + +-- A set of decisions records expn variables that have been identified +-- and those that are distinct. +data Decision t = Decision + { same :: [(t, t)], + dist :: [(t, t)] } + deriving Show + +-- Create an initial set of decisions +mkDecis :: Decision Id +mkDecis = + Decision { + same = [], + dist = [] } + +-- Ensure bases elements in t are never identified +mkInitMatchDecis :: Group -> Decision Id +mkInitMatchDecis t = + mkDecis { dist = [(x, y) | x <- v, y <- v, x /= y] } + where + v = [x | (x, (be, _)) <- M.assocs t, be] + +-- Move fresh variables on the RHS of the equation to the LHS +-- Move variables of sort expn on the LHS to the RHS +partition :: Group -> Group -> Set Id -> ([Maplet], [Maplet]) +partition t0 t1 v = + (M.assocs lhs, M.assocs rhs) + where + (v1, c1) = M.partitionWithKey g t1 -- Fresh variables go in v1 + g x _ = S.member x v + (v0, c0) = M.partition f t0 -- Basis elements go in c0 + f (be, _) = not be + lhs = mul v0 (invert v1) + rhs = mul c1 (invert c0) + +-- Solve equation when there are no variables of sort expr on LHS. +-- Treat all variables as constants. +constSolve :: [Maplet] -> Set Id -> Gen -> IdMap -> + Decision Id -> [(Set Id, Gen, IdMap)] +constSolve t v g r d + | any (\(_, (be, _)) -> not be) t = [] -- Fail expr var is on RHS + | otherwise = constSolve1 t v g r d -- All vars are expn + +constSolve1 :: [Maplet] -> Set Id -> Gen -> + IdMap -> Decision Id -> [(Set Id, Gen, IdMap)] +constSolve1 [] v g r _ = return (v, g, r) +constSolve1 t v g r d = + case orientDecis v $ nextDecis d t of + [] -> [] -- All decisions already made + ((x, y):_) -> -- Pick first undecided pair + distinct ++ identified + where + distinct = constSolve1 t v g r neq + neq = d {dist = (x, y):(y, x):dist d} -- Add new constraints + -- eliminate x + identified = constSolve1 t' v' g r' d' + t' = identify x y t -- Equate x y in t + v' = S.delete x v -- Eliminate x in v + r' = eliminate x y' r -- And in r + y' = groupVar True y + d' = d {same = (x, y):same d} -- And note decision + +-- Find a pair of variables for which no decision has been made. +nextDecis :: Decision Id -> [Maplet] -> [(Id, Id)] +nextDecis d t = + [(x, y) | x <- vars, y <- vars, x < y, + not $ decided d x y] + where + vars = foldr f [] t + f (x, (True, _)) v = x:v + f (_, (False, _)) v = v + decided d x y = -- Is x and y decided? + u == v || + any f (dist d) + where + u = chase x -- Find canonical representitive for x and y + v = chase y + f (w, z) = chase w == u && chase z == v + chase = listChase (same d) + +-- Find canonical representive of the set of identified variables. +listChase :: Eq t => [(t, t)] -> t -> t +listChase d x = + case lookup x d of + Nothing -> x + Just y -> listChase d y + +-- Ensure first var in pair is in v. +orientDecis :: Set Id -> [(Id, Id)] -> [(Id, Id)] +orientDecis v undecided = + map f undecided + where + f (x, y) + | S.notMember x v = (y, x) + | otherwise = (x, y) + +-- Modify t by replacing x by y. +identify :: Id -> Id -> [Maplet] -> [Maplet] +identify x y t = + case lookup x t of + Nothing -> error ("Algebra.identify: bad lookup of " ++ show x + ++ " in " ++ show t) + Just (_, c) -> + filter f (map g t) + where + f (z, (_, c)) = z /= x && c /= 0 + g m@(z, (be, d)) + | z == y = (z, (be, c + d)) + | otherwise = m + +-- Solve when variables of sort expr are on LHS. This involves +-- solving using the group axioms. The algorithm for matching in the +-- group without added constant symbols is the same as the one for +-- unification with constant symbols. +-- +-- For this description, additive notation is used for the group. To +-- show sums, we write +-- +-- sum[i] c[i]*x[i] for c[0]*x[0] + c[1]*x[1] + ... + c[n-1]*x[n-1]. +-- +-- The unification problem is to solve +-- +-- sum[i] c[i]*x[i] = sum[j] d[j]*y[j] +-- +-- where x[i] is a variable and y[j] is a constant symbol. +-- +-- The algorithm used to find solutions is described in Vol. 2 of The +-- Art of Computer Programming / Seminumerical Alorithms, 2nd Ed., +-- 1981, by Donald E. Knuth, pg. 327. +-- +-- The algorithm's initial values are the linear equation (c,d) and an +-- empty substitution s. +-- +-- 1. Let c[i] be the smallest non-zero coefficient in absolute value. +-- +-- 2. If c[i] < 0, multiply c and d by -1 and goto step 1. +-- +-- 3. If c[i] = 1, a general solution of the following form has been +-- found: +-- +-- x[i] = sum[j] -c'[j]*x[j] + d[k] for all k +-- +-- where c' is c with c'[i] = 0. Use the equation to eliminate x[i] +-- from the range of the current substitution s. If variable x[i] is +-- in the original equation, add the mapping to substitution s. +-- +-- 4. If c[i] divides every coefficient in c, +-- +-- * if c[i] divides every constant in d, divide c and d by c[i] +-- and goto step 3, +-- +-- * otherwise fail because there is no solution. In this case +-- expn vars must be identified. +-- +-- 5. Otherwise, eliminate x[i] as above in favor of freshly created +-- variable x[n], where n is the length of c. +-- +-- x[n] = sum[j] (c[j] div c[i] * x[j]) +-- +-- Goto step 1 and solve the equation: +-- +-- c[i]*x[n] + sum[j] (c[j] mod c[i])*x[j] = d[k] for all k + +solve :: [Maplet] -> [Maplet] -> Set Id -> Gen -> + IdMap -> Decision Id -> [(Set Id, Gen, IdMap)] +solve t0 t1 v g r d = + let (x, ci, i) = smallest t0 in -- ci is the smallest coefficient, + case compare ci 0 of -- x is its variable, i its position + GT -> agSolve x ci i t0 t1 v g r d + LT -> agSolve x (-ci) i (mInverse t0) (mInverse t1) v g r d -- Step 2 + EQ -> error "Algebra.solve: zero coefficient found" + +-- Find the factor with smallest coefficient in absolute value. +-- Returns the variable, the coefficient, and the position within the +-- list. +smallest :: [Maplet] -> (Id, Int, Int) +smallest [] = error "Algebra.smallest given an empty list" +smallest t = + loop (Id (0, "x")) 0 0 0 0 t + where + loop v ci i _ _ [] = (v, ci, i) + loop v ci i a j ((x, (_, c)):t) = + if a < abs c then + loop x c j (abs c) (j + 1) t + else + loop v ci i a (j + 1) t + +-- The group axioms are abbreviated by AG. +agSolve :: Id -> Int -> Int -> [Maplet] -> [Maplet] -> Set Id -> Gen -> + IdMap -> Decision Id -> [(Set Id, Gen, IdMap)] +agSolve x 1 i t0 t1 v g r _ = -- Solve for x and return answer + return (S.delete x v, g, eliminate x t r) -- Step 3 + where + t = G $ group (t1 ++ (mInverse (omit i t0))) +agSolve x ci i t0 t1 v g r d + | divisible ci t0 = -- Step 4 + if divisible ci t1 then -- Solution found + agSolve x 1 i (divide ci t0) (divide ci t1) v g r d + else -- No possible solution without identifying variables + identSolve x ci i t0 t1 v g r d + | otherwise = -- Step 5, eliminate x in favor of x' + solve t0' t1 (S.insert x' $ S.delete x v) g' r' d + where + (g', x') = cloneId g x + t = G $ group ((x', (False, 1)) : + mInverse (divide ci (omit i t0))) + r' = eliminate x t r + t0' = (x', (False, ci)) : modulo ci (omit i t0) + +eliminate :: Id -> Term -> IdMap -> IdMap +eliminate x t r = + M.map (idSubst (M.singleton x t)) r + +omit :: Int -> [a] -> [a] +omit 0 (_:l) = l +omit n _ | n < 0 = error "Algebra.omit: negative number given to omit" +omit n (_:l) = omit (n - 1) l +omit _ [] = error "Algebra.omit: number given to omit too large" + +divisible :: Int -> [Maplet] -> Bool +divisible ci t = + all (\(_, (_, c)) -> mod c ci == 0) t + +divide :: Int -> [Maplet] -> [Maplet] +divide ci t = map (mMapCoef $ flip div ci) t + +modulo :: Int -> [Maplet] -> [Maplet] +modulo ci t = + [(x, (be, c')) | + (x, (be, c)) <- t, + let c' = mod c ci, + c' /= 0] + +-- Explore two choices as to whether to identify a pair of variables. +identSolve :: Id -> Int -> Int -> [Maplet] -> [Maplet] -> Set Id -> Gen -> + IdMap -> Decision Id -> [(Set Id, Gen, IdMap)] +identSolve z ci i t0 t1 v g r d = + case orientDecis v $ nextDecis d t1 of + [] -> [] + ((x, y):_) -> + distinct ++ identified + where + distinct = identSolve z ci i t0 t1 v g r neq + neq = d {dist = (x, y):(y, x):dist d} + -- eliminate x + identified = agSolve z ci i t0 t1' v' g r' d' + t1' = identify x y t1 -- Equate x y in t1 + v' = S.delete x v -- Eliminate x in v + r' = eliminate x y' r -- And in r + y' = groupVar True y + d' = d {same = (x, y):same d} + +-- Does every varible in ts not occur in the domain of e? +-- Trivial bindings in e are ignored. +identityEnvFor :: GenEnv -> [Term] -> [GenEnv] +identityEnvFor ge ts = + let env@(_, Env (_, r)) = nonTrivialEnv ge in + if all (allId $ flip S.notMember $ M.keysSet r) ts then + [env] + else + [] + +allId :: (Id -> Bool) -> Term -> Bool +allId f (I x) = f x +allId _ (C _) = True +allId f (F _ u) = all (allId f) u +allId f (G t) = all f (M.keys t) + +-- Eliminate all trivial bindings so that an environment can be used +-- as a substitution. +nonTrivialEnv :: GenEnv -> GenEnv +nonTrivialEnv (g, Env (v, r)) = + (g, Env (v, M.filterWithKey nonTrivialBinding r)) + +{-- +nonTrivialEnv (g, Env (v, r)) = + nonGroupEnv (M.assocs r) M.empty [] + where + nonGroupEnv [] env grp = + groupEnv g v env grp grp + nonGroupEnv ((x, I y):r) env grp + | x == y = nonGroupEnv r env grp + nonGroupEnv ((x, G y):r) env grp + | isGroupVar y && getGroupVar y == x = + nonGroupEnv r env grp + | otherwise = nonGroupEnv r env ((x, y):grp) + nonGroupEnv ((x, y):r) env grp = + nonGroupEnv r (M.insert x y env) grp + +groupEnv :: Gen -> Set Id -> IdMap -> [(Id, Group)] -> [(Id, Group)] -> GenEnv +groupEnv g v env grp [] = + (g, Env (v, foldl (\env (x, y) -> M.insert x (G y) env) env grp)) +groupEnv g v env grp ((x, t):map) + | M.lookup x t /= Just 1 = groupEnv g v env grp map + | otherwise = + let (t0, t1) = partition M.empty (mul t (M.singleton x (-1))) v in + case matchGroup (group t0) (group t1) S.empty g of + Nothing -> groupEnv g v env grp map + Just (v', g', subst) -> + let grp' = L.delete (x, t) grp + grp'' = L.map (\(x, t) -> (x, groupSubst subst t)) grp' in + groupEnv g' (S.union v' v) env grp'' grp'' + +notGroupVarMap :: Id -> Group -> Bool +notGroupVarMap x grp = + case M.lookup x t of + Nothing -> True + Just (_, (_, c)) -> c /= 1 + +-} + +substitution :: Env -> Subst +substitution (Env (_, r)) = + Subst $ M.filterWithKey nonTrivialBinding r + +-- Add type information to an environment, and return it as a list of +-- associations. + +reify :: [Term] -> Env -> [(Term, Term)] +reify domain (Env (_, env)) = + map (loop domain) $ M.assocs env + where + loop [] (x, _) = + error $ "Algebra.reify: variable missing from domain " ++ idName x + ++ " = " ++ show x ++ "\n" ++ show domain ++ "\n" ++ show env + loop (I x : _) (y, t) + | x == y = (I x, t) + loop (F Text [I x] : _) (y, t) + | x == y = (F Text [I x], F Text [t]) + loop (F Data [I x] : _) (y, t) + | x == y = (F Data [I x], F Data [t]) + loop (F Name [I x] : _) (y, t) + | x == y = (F Name [I x], F Name [t]) + loop (F Skey [I x] : _) (y, t) + | x == y = (F Skey [I x], F Skey [t]) + loop (F Akey [I x] : _) (y, t) + | x == y = (F Akey [I x], F Akey [t]) + loop (F Base [I x] : _) (y, t) + | x == y = (F Base [I x], F Base [t]) + loop (G x : _) (y, G t) + | isGroupVar x && getGroupVar x == y = (G x, G t) + loop (_ : domain) pair = loop domain pair + +-- Ensure the range of an environment contains only variables and that +-- the environment is injective. +matchRenaming :: GenEnv -> Bool +matchRenaming (_, Env (_, e)) = + loop S.empty $ M.elems e + where + loop _ [] = True + loop s (I x:e) = + S.notMember x s && loop (S.insert x s) e + loop s (G y:e) | isGroupVar y = + let x = getGroupVar y in + S.notMember x s && loop (S.insert x s) e + loop _ _ = False + +{-- +-- Ensure the range of an environment contains only variables and that +-- the environment is injective. +matchRenaming :: GenEnv -> Bool +matchRenaming (gen, Env (v, e)) = + nonGrp S.empty (M.elems e) && + groupMatchRenaming v gen (M.foldrWithKey grp M.empty e) + where + nonGrp _ [] = True + nonGrp s (I x:e) = + S.notMember x s && nonGrp (S.insert x s) e + nonGrp s (G _:e) = nonGrp s e -- Check group bindings elsewhere + nonGrp _ _ = False + grp x (G t) map = M.insert x t map + grp _ _ map = map -- Get rid of non-group bindings + +groupMatchRenaming :: Set Id -> Gen -> Map Id Group -> Bool +groupMatchRenaming v gen map = + loop S.empty $ M.elems map + where + loop _ [] = True + loop s (t:ge) + | M.null t = False + | isGroupVar t = + let x = getGroupVar t in + S.notMember x s && loop (S.insert x s) ge + | otherwise = any (groupMatchElim v gen map t) (M.assocs t) + +groupMatchElim :: Set Id -> Gen -> Map Id Group -> Group -> Maplet -> Bool +groupMatchElim v gen ge t (x, (be, 1)) = + let (t0, t1) = partition M.empty (mul t (mlGrp (x, (be, -1)))) v in + any f (matchGroup (group t0) (group t1) S.empty gen) + where + f (v', gen', subst) = + groupMatchRenaming (S.union v' v) gen' $ M.map (groupSubst subst) ge +groupMatchElim _ _ _ _ _ = False +-} + +instance C.Env Term Gen Subst Env where + emptyEnv = emptyEnv + instantiate = instantiate + match = match + identityEnvFor = identityEnvFor + substitution = substitution + reify = reify + matchRenaming = matchRenaming + +-- Term specific loading functions + +loadVars :: Monad m => Gen -> [SExpr Pos] -> m (Gen, [Term]) +loadVars gen sexprs = + do + pairs <- mapM loadVarPair sexprs + (g, vars) <- foldM loadVar (gen, []) (concat pairs) + return (g, reverse vars) + +loadVarPair :: Monad m => SExpr Pos -> m [(SExpr Pos, SExpr Pos)] +loadVarPair (L _ (x:xs)) = + let (t:vs) = reverse (x:xs) in + return [(v,t) | v <- reverse vs] +loadVarPair x = fail (shows (annotation x) "Bad variable declaration") + +loadVar :: Monad m => (Gen, [Term]) -> (SExpr Pos, SExpr Pos) -> + m (Gen, [Term]) +loadVar (gen, vars) (S pos name, S pos' sort) = + case loadLookup pos vars name of + Right _ -> + fail (shows pos "Duplicate variable declaration for " ++ name) + Left _ -> + do + let (gen', x) = freshId gen name + p <- mkVar x + return (gen', p : vars) + where + mkVar x = + let t = I x in + case sort of + "mesg" -> return t + "text" -> return $ F Text [t] + "data" -> return $ F Data [t] + "name" -> return $ F Name [t] + "skey" -> return $ F Skey [t] + "akey" -> return $ F Akey [t] + "base" -> return $ F Base [t] + "expr" -> return $ groupVar False x + "expn" -> return $ groupVar True x + _ -> fail (shows pos' "Sort " ++ sort ++ " not recognized") +loadVar _ (x,_) = fail (shows (annotation x) "Bad variable syntax") + +loadLookup :: Pos -> [Term] -> String -> Either String Term +loadLookup pos [] name = Left (shows pos $ "Identifier " ++ name ++ " unknown") +loadLookup pos (t : u) name = + let name' = idName (varId t) in + if name' == name then Right t else loadLookup pos u name + +loadLookupName :: Monad m => Pos -> [Term] -> String -> m Term +loadLookupName pos vars name = + either fail f (loadLookup pos vars name) + where + f t@(F Name [I _]) = return t + f _ = fail (shows pos $ "Expecting " ++ name ++ " to be a name") + +loadLookupAkey :: Monad m => Pos -> [Term] -> String -> m Term +loadLookupAkey pos vars name = + either fail f (loadLookup pos vars name) + where + f t@(F Akey [I _]) = return t + f _ = fail (shows pos $ "Expecting " ++ name ++ " to be an akey") + +-- Load term and check that it is well-formed. +loadTerm :: Monad m => [Term] -> SExpr Pos -> m Term +loadTerm vars (S pos s) = + either fail return (loadLookup pos vars s) +loadTerm _ (Q _ t) = + return (C t) +loadTerm vars (L pos (S _ s : l)) = + case lookup s loadDispatch of + Nothing -> fail (shows pos "Keyword " ++ s ++ " unknown") + Just f -> f pos vars l +loadTerm _ x = fail (shows (annotation x) "Malformed term") + +type LoadFunction m = Pos -> [Term] -> [SExpr Pos] -> m Term + +loadDispatch :: Monad m => [(String, LoadFunction m)] +loadDispatch = + [("pubk", loadPubk) + ,("privk", loadPrivk) + ,("invk", loadInvk) + ,("ltk", loadLtk) + ,("gen", loadGen) + ,("exp", loadExp) + ,("one", loadOne) + ,("rec", loadRec) + ,("mul", loadMul) + ,("cat", loadCat) + ,("enc", loadEnc) + ,("hash", loadHash) + ] + +-- Atom constructors: pubk privk invk ltk + +loadPubk :: Monad m => LoadFunction m +loadPubk _ vars [S pos s] = + do + t <- loadLookupName pos vars s + return $ F Akey [F Pubk [I $ varId t]] +loadPubk _ vars [Q _ c, S pos s] = + do + t <- loadLookupName pos vars s + return $ F Akey [F Pubk [C c, I $ varId t]] +loadPubk pos _ _ = fail (shows pos "Malformed pubk") + +loadPrivk :: Monad m => LoadFunction m +loadPrivk _ vars [S pos s] = + do + t <- loadLookupName pos vars s + return $ F Akey [F Invk [F Pubk [I $ varId t]]] +loadPrivk _ vars [Q _ c, S pos s] = + do + t <- loadLookupName pos vars s + return $ F Akey [F Invk [F Pubk [C c, I $ varId t]]] +loadPrivk pos _ _ = fail (shows pos "Malformed privk") + +loadInvk :: Monad m => LoadFunction m +loadInvk _ vars [S pos s] = + do + t <- loadLookupAkey pos vars s + return $ F Akey [F Invk [I $ varId t]] +loadInvk pos _ _ = fail (shows pos "Malformed invk") + +loadLtk :: Monad m => LoadFunction m +loadLtk _ vars [S pos s, S pos' s'] = + do + t <- loadLookupName pos vars s + t' <- loadLookupName pos' vars s' + return $ F Skey [F Ltk [I $ varId t, I $ varId t']] +loadLtk pos _ _ = fail (shows pos "Malformed ltk") + +-- Base and exponents + +loadGen :: Monad m => LoadFunction m +loadGen _ _ [] = + return $ F Base [F Genr []] +loadGen pos _ _ = fail (shows pos "Malformed gen") + +loadExp :: Monad m => LoadFunction m +loadExp _ vars [x, x'] = + do + t <- loadBase vars x + t' <- loadExpr vars x' + return $ F Base [idSubst emptyIdMap $ F Exp [t, G t']] +loadExp pos _ _ = fail (shows pos "Malformed exp") + +loadBase :: Monad m => [Term] -> SExpr Pos -> m Term +loadBase vars x = + do + t <- loadTerm vars x + case t of + F Base [t] -> return t + _ -> fail (shows (annotation x) "Malformed base") + +loadExpr :: Monad m => [Term] -> SExpr Pos -> m Group +loadExpr vars x = + do + t <- loadTerm vars x + case t of + G t -> return t + _ -> fail (shows (annotation x) "Malformed expr") + +loadOne :: Monad m => LoadFunction m +loadOne _ _ [] = + return $ G M.empty +loadOne pos _ _ = fail (shows pos "Malformed one") + +loadRec :: Monad m => LoadFunction m +loadRec _ vars [x] = + do + t <- loadExpr vars x + return $ G $ invert t +loadRec pos _ _ = fail (shows pos "Malformed rec") + +loadMul :: Monad m => LoadFunction m +loadMul _ vars xs = + do + t <- foldM f M.empty xs + return $ G t + where + f acc x = + do + t <- loadExpr vars x + return $ mul t acc + +-- Term constructors: cat enc + +loadCat :: Monad m => LoadFunction m +loadCat _ vars (l : ls) = + do + ts <- mapM (loadTerm vars) (l : ls) + return $ foldr1 (\a b -> F Cat [a, b]) ts +loadCat pos _ _ = fail (shows pos "Malformed cat") + +loadEnc :: Monad m => LoadFunction m +loadEnc pos vars (l : l' : ls) = + do + let (butLast, last) = splitLast l (l' : ls) + t <- loadCat pos vars butLast + t' <- loadTerm vars last + return $ F Enc [t, t'] +loadEnc pos _ _ = fail (shows pos "Malformed enc") + +splitLast :: a -> [a] -> ([a], a) +splitLast x xs = + loop [] x xs + where + loop z x [] = (reverse z, x) + loop z x (y : ys) = loop (x : z) y ys + +loadHash :: Monad m => LoadFunction m +loadHash _ vars (l : ls) = + do + ts <- mapM (loadTerm vars) (l : ls) + return $ F Hash [foldr1 (\a b -> F Cat [a, b]) ts] +loadHash pos _ _ = fail (shows pos "Malformed hash") + +-- Term specific displaying functions + +newtype Context = Context [(Id, String)] deriving Show + +displayVars :: Context -> [Term] -> [SExpr ()] +displayVars _ [] = [] +displayVars ctx vars = + let (v,t):pairs = map (displayVar ctx) vars in + loop t [v] pairs + where + loop t vs [] = [L () (reverse (t:vs))] + loop t vs ((v',t'):xs) + | t == t' = loop t (v':vs) xs + | otherwise = L () (reverse (t:vs)):loop t' [v'] xs + +displayVar :: Context -> Term -> (SExpr (), SExpr ()) +displayVar ctx (I x) = displaySortId "mesg" ctx x +displayVar ctx (F Text [I x]) = displaySortId "text" ctx x +displayVar ctx (F Data [I x]) = displaySortId "data" ctx x +displayVar ctx (F Name [I x]) = displaySortId "name" ctx x +displayVar ctx (F Skey [I x]) = displaySortId "skey" ctx x +displayVar ctx (F Akey [I x]) = displaySortId "akey" ctx x +displayVar ctx (F Base [I x]) = displaySortId "base" ctx x +displayVar ctx t@(G x) + | isBasisVar x = displaySortId "expn" ctx (varId t) + | isGroupVar x = displaySortId "expr" ctx (varId t) +displayVar _ _ = + error "Algebra.displayVar: term not a variable with its sort" + +displaySortId :: String -> Context -> Id -> (SExpr (), SExpr ()) +displaySortId sort ctx x = (displayId ctx x, S () sort) + +displayId :: Context -> Id -> SExpr () +displayId (Context ctx) x = + case lookup x ctx of + Nothing -> + let msg = idName x ++ " in a display context" in + error $ "Algebra.displayId: Cannot find variable " ++ msg + Just name -> S () name + +displayTerm :: Context -> Term -> SExpr () +displayTerm ctx (I x) = displayId ctx x +displayTerm ctx (F Text [I x]) = displayId ctx x +displayTerm ctx (F Data [I x]) = displayId ctx x +displayTerm ctx (F Name [I x]) = displayId ctx x +displayTerm ctx (F Skey [I x]) = displayId ctx x +displayTerm ctx (F Skey [F Ltk [I x, I y]]) = + L () [S () "ltk", displayId ctx x, displayId ctx y] +displayTerm ctx (F Akey [t]) = + case t of + I x -> displayId ctx x + F Invk [I x] -> L () [S () "invk", displayId ctx x] + F Pubk [I x] -> L () [S () "pubk", displayId ctx x] + F Pubk [C c, I x] -> L () [S () "pubk", Q () c, displayId ctx x] + F Invk [F Pubk [I x]] -> L () [S () "privk", displayId ctx x] + F Invk [F Pubk [C c, I x]] -> + L () [S () "privk", Q () c, displayId ctx x] + _ -> error ("Algebra.displayAkey: Bad term " ++ show t) +displayTerm ctx (F Base [t]) = + displayBase t + where + displayBase (I x) = displayId ctx x + displayBase (F Genr []) = + L () [S () "gen"] + displayBase (F Exp [t0, G t1]) = + L () [S () "exp", displayBase t0, displayTerm ctx (G t1)] + displayBase t = error ("Algebra.displayBase: Bad term " ++ show t) +displayTerm ctx (G t) = + displayExpr t + where + displayExpr t + | M.null t = L () [S () "one"] + | otherwise = + case factors t of + [f] -> displayFactor f + fs -> L () (S () "mul" : map displayFactor fs) + displayFactor (x, n) + | n >= 0 = displayId ctx x + | otherwise = L () [S () "rec", displayId ctx x] +displayTerm _ (C t) = Q () t +displayTerm ctx (F Cat [t0, t1]) = + L () (S () "cat" : displayTerm ctx t0 : displayList ctx t1) +displayTerm ctx (F Enc [t0, t1]) = + L () (S () "enc" : displayEnc ctx t0 t1) +displayTerm ctx (F Hash [t]) = + L () (S () "hash" : displayList ctx t) +displayTerm _ t = error ("Algebra.displayTerm: Bad term " ++ show t) + +displayList :: Context -> Term -> [SExpr ()] +displayList ctx (F Cat [t0, t1]) = displayTerm ctx t0 : displayList ctx t1 +displayList ctx t = [displayTerm ctx t] + +displayEnc :: Context -> Term -> Term -> [SExpr ()] +displayEnc ctx (F Cat [t0, t1]) t = displayTerm ctx t0 : displayEnc ctx t1 t +displayEnc ctx t0 t1 = [displayTerm ctx t0, displayTerm ctx t1] + +displayEnv :: Context -> Context -> Env -> [SExpr ()] +displayEnv ctx ctx' (Env (_, r)) = + map (\(x, t) -> L () [displayTerm ctx x, displayTerm ctx' t]) r' + where + r' = map (\(x, t) -> (I x, inferSort t)) $ M.assocs r + +factors :: Group -> [(Id, Int)] +factors t = + do + (x, (_, n)) <- M.assocs t + case n >= 0 of + True -> replicate n (x, 1) + False -> replicate (negate n) (x, -1) + +-- displaySubst c s displays a substitution s in context c, where some +-- variables that occur in s might not be in c. Enough sort +-- inference is performed so as to allow the extension of the context. +displaySubst :: Context -> Subst -> [SExpr ()] +displaySubst ctx s@(Subst r) = + map (\(x, t) -> L () [displayTerm ctx' x, displayTerm ctx' t]) r' + where + r' = map (\(x, t) -> (I x, inferSort (substitute s t))) $ M.assocs r + ctx' = foldl (\ctx (x, t) -> addToContext ctx [x, t]) ctx r' + +inferSort :: Term -> Term +inferSort t@(F Invk _) = F Akey [t] +inferSort t@(F Pubk _) = F Akey [t] +inferSort t@(F Ltk _) = F Skey [t] +inferSort t@(F Genr _) = F Base [t] +inferSort t@(F Exp _) = F Base [t] +inferSort t = t + +emptyContext :: Context +emptyContext = Context [] + +-- Generate names for output renaming as necessary. +-- Assumes the input is a list of term that are well-formed +addToContext :: Context -> [Term] -> Context +addToContext ctx u = + foldl (foldVars varContext) ctx u + +varContext :: Context -> Term -> Context +varContext ctx t = + let x = varId t + name = rootName $ idName x in + if hasId ctx x then + ctx + else + if hasName ctx name then + extendContext ctx x (genName ctx name) + else + extendContext ctx x name + +hasId :: Context -> Id -> Bool +hasId (Context ctx) id = + maybe False (const True) (lookup id ctx) + +hasName :: Context -> String -> Bool +hasName (Context ctx) name = + maybe False (const True) (L.find ((name ==) . snd) ctx) + +extendContext :: Context -> Id -> String -> Context +extendContext (Context ctx) x name = + Context $ (x, name) : ctx + +genName :: Context -> String -> String +genName ctx name = + loop 0 + where + root = '-' : reverse name + loop :: Int -> String + loop n = + let name' = revapp root (show n) in + if hasName ctx name' then + loop (n + 1) + else + name' + revapp [] s = s + revapp (c : cs) s = revapp cs (c : s) + +rootName :: String -> String +rootName name = + noHyphen 0 name + where + noHyphen _ [] = name + noHyphen i (c : s) + | c == '-' = hyphen i (i + 1) s + | otherwise = noHyphen (i + 1) s + hyphen i _ [] = rootName $ take i name + hyphen i j (c : s) + | isDigit c = hyphen i (j + 1) s + | otherwise = noHyphen j (c : s) + +instance C.Context Term Gen Subst Env Context where + emptyContext = emptyContext + addToContext = addToContext + displayVars = displayVars + displayTerm = displayTerm + displayEnv = displayEnv + displaySubst = displaySubst instance C.Algebra Term Place Gen Subst Env Context diff --git a/src/CPSA/DiffieHellman/IntLinEq.hs b/src/CPSA/DiffieHellman/IntLinEq.hs deleted file mode 100644 --- a/src/CPSA/DiffieHellman/IntLinEq.hs +++ /dev/null @@ -1,197 +0,0 @@ --- Integer Solutions of Linear Inhomogeneous Equations - --- Copyright (c) 2009 The MITRE Corporation --- --- This program is free software: you can redistribute it and/or --- modify it under the terms of the BSD License as published by the --- University of California. - --- | --- Module : CPSA.DiffieHellman.IntLinEq --- Copyright : (c) 2009 The MITRE Corporation --- License : BSD --- --- Integer Solutions of Linear Inhomogeneous Equations --- --- A linear equation with integer coefficients is represented as a --- pair of lists of non-zero integers, the coefficients and the --- constants. If there are no constants, the linear equation --- represented by (c, []) is the homogeneous equation: --- --- > c[0]*x[0] + c[1]*x[1] + ... + c[n-1]*x[n-1] = 0 --- --- where n is the length of c. Otherwise, (c, d) represents the --- inhomogeneous equation: --- --- > c[0]*x[0] + c[1]*x[1] + ... + c[n-1]*x[n-1] = g --- --- where g = gcd(d[0], d[1], ..., d[m-1]), and m is the length of d. --- Thus g is the greatest common denominator of the elements of d. --- --- A solution is a partial map from variables to terms, and a term is --- a pair of lists of integers, the variable part of the term followed --- by the constant part. The variable part may specify variables not --- in the input. In other words, the length of the coefficents in the --- answer may exceed the length of the coefficients in the input. For --- example, the solution of --- --- > 64x - 41y = 1 --- --- is x = -41z - 16 and y = -64z - 25. The computed solution is read --- off the list returned as an answer. --- --- > intLinEq [64,-41] [1] = --- > [(0,([0,0,0,0,0,0,-41],[-16])), --- > (1,([0,0,0,0,0,0,-64],[-25]))] --- --- The algorithm used to find solutions is described in Vol. 2 of The --- Art of Computer Programming \/ Seminumerical Alorithms, 2nd Ed., --- 1981, by Donald E. Knuth, pg. 327. To show sums, we write --- --- > sum[i] c[i]*x[i] for c[0]*x[0] + c[1]*x[1] + ... + c[n-1]*x[n-1]. --- --- The algorithm's initial values are the linear equation (c,d) and an --- empty substitution s. --- --- 1. Let c[i] be the smallest non-zero coefficient in absolute value. --- --- 2. If c[i] < 0, multiply c and d by -1 and goto step 1. --- --- 3. If c[i] = 1, a general solution of the following form has been --- found: --- --- > x[i] = sum[j] -c'[j]*x[j] + d[k] for all k --- --- where c' is c with c'[i] = 0. Use the equation to eliminate x[i] --- from the range of the current substitution s. If variable x[i] is --- in the original equation, add the mapping to substitution s. --- --- 4. If c[i] divides every coefficient in c, --- --- * if c[i] divides every constant in d, divide c and d by c[i] --- and goto step 3, --- --- * otherwise fail because there is no solution. --- --- 5. Otherwise, eliminate x[i] as above in favor of freshly created --- variable x[n], where n is the length of c. --- --- > x[n] = sum[j] (c[j] div c[i] * x[j]) --- --- Goto step 1 and solve the equation: --- --- > c[i]*x[n] + sum[j] (c[j] mod c[i])*x[j] = d[k] for all k - -module CPSA.DiffieHellman.IntLinEq - (LinEq, Subst, intLinEq) where - --- | A linear equation with integer coefficients is represented as a --- pair of lists of non-zero integers, the coefficients and the --- constants. -type LinEq = ([Int], [Int]) - --- | A solution to a linear equation is a partial map from variables --- to terms, and a term is a pair of lists of integers, the variable --- part of the term followed by the constant part. The variable part --- may specify variables not in the input. In other words, the length --- of the coefficents in the answer may exceed the length of the --- coefficients in the input. -type Subst = [(Int, LinEq)] - --- | Find integer solutions to a linear equation or fail when there --- are no solutions. -intLinEq :: Monad m => LinEq -> m Subst -intLinEq (coefficients, constants) = - intLinEqLoop (length coefficients) (coefficients, constants) [] - --- The algorithm used to find solutions is described in Vol. 2 of The --- Art of Computer Programming / Seminumerical Alorithms, 2nd Ed., --- 1981, by Donald E. Knuth, pg. 327. - --- On input, n is the number of variables in the original problem, c --- is the coefficients, d is the constants, and subst is a list of --- eliminated variables. -intLinEqLoop :: Monad m => Int -> LinEq -> Subst -> m Subst -intLinEqLoop n (c, d) subst = - -- Find the smallest non-zero coefficient in absolute value - let (i, ci) = smallest c in - case () of - _ | ci < 0 -> intLinEqLoop n (invert c, invert d) subst - -- Ensure the smallest coefficient is positive - | ci == 0 -> fail "bad problem" - -- Lack of non-zero coefficients is an error - | ci == 1 -> - -- A general solution of the following form has been found: - -- x[i] = sum[j] -c'[j]*x[j] + d[k] for all k - -- where c' is c with c'[i] = 0. - return $ eliminate n (i, (invert (zero i c), d)) subst - | divisible ci c -> - -- If all the coefficients are divisible by c[i], a solution is - -- immediate if all the constants are divisible by c[i], - -- otherwise there is no solution. - if divisible ci d then - let c' = divide ci c - d' = divide ci d in - return $ eliminate n (i, (invert (zero i c'), d')) subst - else - fail "no solution" - | otherwise -> - -- Eliminate x[i] in favor of freshly created variable x[n], - -- where n is the length of c. - -- x[n] = sum[j] (c[j] div c[i] * x[j]) - -- The new equation to be solved is: - -- c[i]*x[n] + sum[j] (c[j] mod c[i])*x[j] = d[k] for all k - intLinEqLoop n (map (\x -> mod x ci) c ++ [ci], d) subst' - where - subst' = eliminate n (i, (invert c' ++ [1], [])) subst - c' = divide ci (zero i c) - --- Find the smallest non-zero coefficient in absolute value -smallest :: [Int] -> (Int, Int) -smallest xs = - foldl f (-1, 0) (zip [0..] xs) - where - f (i, n) (j, x) - | n == 0 = (j, x) - | x == 0 || abs n <= abs x = (i, n) - | otherwise = (j, x) - -invert :: [Int] -> [Int] -invert t = map negate t - --- Zero the ith position in a list -zero :: Int -> [Int] -> [Int] -zero _ [] = [] -zero 0 (_:xs) = 0 : xs -zero i (x:xs) = x : zero (i - 1) xs - --- Eliminate a variable from the existing substitution. If the --- variable is in the original problem, add it to the substitution. -eliminate :: Int -> (Int, LinEq) -> Subst -> Subst -eliminate n m@(i, (c, d)) subst = - if i < n then - m : map f subst - else - map f subst - where - f m'@(i', (c', d')) = -- Eliminate i in c' if it occurs in c' - case get i c' of - 0 -> m' -- i is not in c' - ci -> (i', (addmul ci (zero i c') c, addmul ci d' d)) - -- Find ith coefficient - get _ [] = 0 - get 0 (x:_) = x - get i (_:xs) = get (i - 1) xs - -- addnum n xs ys sums xs and ys after multiplying ys by n - addmul 1 [] ys = ys - addmul n [] ys = map (* n) ys - addmul _ xs [] = xs - addmul n (x:xs) (y:ys) = (x + n * y) : addmul n xs ys - -divisible :: Int -> [Int] -> Bool -divisible small t = - all (\x -> mod x small == 0) t - -divide :: Int -> [Int] -> [Int] -divide small t = - map (\x -> div x small) t diff --git a/src/CPSA/DiffieHellmanNoReciprocal/Algebra.hs b/src/CPSA/DiffieHellmanNoReciprocal/Algebra.hs deleted file mode 100644 --- a/src/CPSA/DiffieHellmanNoReciprocal/Algebra.hs +++ /dev/null @@ -1,1617 +0,0 @@ --- Diffie-Hellman Without Reciprocals Algebra implementation - --- This module is a version of Diffie-Hellman in which exponents form --- an commutative monoid. There are issues to be resolved before this --- version of Diffie-Hellman can be used. - --- The module implements a many-sorted algebra, but is used as an --- order-sorted algebra. It exports a name, and the origin used to --- generate variables. - --- Copyright (c) 2009 The MITRE Corporation --- --- This program is free software: you can redistribute it and/or --- modify it under the terms of the BSD License as published by the --- University of California. - -{-# LANGUAGE MultiParamTypeClasses, CPP #-} - --- #define INTERACTIVE_DEBUGGING - -module CPSA.DiffieHellmanNoReciprocal.Algebra (name, origin -#if defined INTERACTIVE_DEBUGGING - , iUnify, iMatch -#endif - ) where - -#if defined INTERACTIVE_DEBUGGING -import System.IO(stdin) -import Control.Exception(try) -#endif - -import Control.Monad (foldM) -import qualified Data.List as L -import qualified Data.Set as S -import Data.Set (Set) -import qualified Data.Map as M -import Data.Map (Map) -import Data.Char (isDigit) -import qualified CPSA.Lib.CPSA as C -import CPSA.Lib.CPSA (SExpr(..), Pos, annotation) -import qualified CPSA.DiffieHellmanNoReciprocal.LinDiophEq as D - -{-- Debugging support -import System.IO.Unsafe - -z :: Show a => a -> b -> b -z x y = unsafePerformIO (print x >> return y) - -zz :: Show a => a -> a -zz x = z x x - -zn :: Show a => a -> Maybe b -> Maybe b -zn x Nothing = z x Nothing -zn _ y = y - -zf :: Show a => a -> Bool -> Bool -zf x False = z x False -zf _ y = y - -zt :: Show a => a -> Bool -> Bool -zt x True = z x True -zt _ y = y ---} - --- Export iUnify and iMatch for debugging in GHCi. --- Both functions request a declaration and then two terms. --- Example: ((x y z expn)) (mul x x y) z -#if defined INTERACTIVE_DEBUGGING -tryIO :: IO a -> IO (Either IOError a) -tryIO x = try x - -iUnify :: IO [Subst] -iUnify = - iRun f emptySubst - where - f t0 t1 r = maybe [] (: []) (unify t0 t1 r) - -iMatch :: IO [Env] -iMatch = - do - ans <- tryIO (iRun aMatch emptyEnv) - case ans of - Right ans -> return ans - Left err -> fail (show err) - where - aMatch t t' (g, e) = map (\e -> (g, e)) $ match t t' e - -iRun :: (Term -> Term -> (Gen, a) -> [(Gen, a)]) -> a -> IO [a] -iRun f mt = - do - sexpr <- load - t <- load - t' <- load - case (sexpr, t, t') of - (Just (L _ vars), Just t, Just t') -> - return (run f mt vars t t') - err -> fail ("bad load: " ++ show err) - -run :: (Term -> Term -> (Gen, a) -> [(Gen, a)]) -> a -> - [SExpr Pos] -> SExpr Pos -> SExpr Pos -> [a] -run f mt vars t t' = - do - (gen, vars) <- loadVars origin vars - t <- loadTerm vars t - t' <- loadTerm vars t' - (_, a) <- f t t' (gen, mt) - return a - -load :: IO (Maybe (SExpr Pos)) -load = - do - h <- C.posHandle "" stdin - content <- tryIO (C.load h) - case content of - Left msg -> - do - print msg - return Nothing - Right sexpr -> return sexpr - -{-- -gRun :: Gen -> Term -> a -> a -gRun (Gen n) t a = - foldVars f a t - where - f a t = - case varId t of - Id (m, _) | m >= n -> error ("Bad gen " ++ show n) - _ -> a - -gMatch :: Term -> Term -> GenEnv -> Maybe GenEnv -gMatch t t' r@(g, _) = gRun g t' (match t t' r) - -gUnify :: Term -> Term -> GenSubst -> Maybe GenSubst -gUnify t t' r@(g, _) = gRun g (F Cat [t, t']) (unify t t' r) ---} -#endif - -name :: String -name = "diffie-hellman-no-reciprocal" - --- An identifier - -newtype Id = Id (Integer, String) deriving Show - --- The integer distinguishes an identifier, the string is for printing. - -instance Eq Id where - (Id (x, _)) == (Id (x', _)) = x == x' - -instance Ord Id where - compare (Id (x, _)) (Id (x', _)) = compare x x' - -idName :: Id -> String -idName (Id (_, name)) = name - --- Counter used for generating fresh identifiers. - -newtype Gen = Gen (Integer) deriving Show - -origin :: Gen -origin = Gen (0) - -freshId :: Gen -> String -> (Gen, Id) -freshId (Gen (i)) name = (Gen (i + 1), Id (i, name)) - -cloneId :: Gen -> Id -> (Gen, Id) -cloneId gen x = freshId gen (idName x) - --- A term in an Abelian group is a map from identifiers to non-zero integers. - -type Group = Map Id Int - -isGroupVar :: Group -> Bool -isGroupVar t = - M.size t == 1 && head (M.elems t) == 1 - -groupVar :: Id -> Term -groupVar x = G $ M.singleton x 1 - -invert :: Group -> Group -invert t = M.map negate t - -expg :: Group -> Int -> Group -expg _ 0 = M.empty -expg t 1 = t -expg t n = M.map (* n) t - -mul :: Group -> Group -> Group -mul t t' = - M.foldrWithKey f t' t -- Fold over the mappings in t - where - f x c t = -- Alter the mapping of - M.alter (g c) x t -- variable x in t - g c Nothing = -- Variable x not currently mapped - Just c -- so add a mapping - g c (Just c') -- Variable x maps to c' - | c + c' == 0 = Nothing -- Delete the mapping - | otherwise = Just $ c + c' -- Adjust the mapping - -group :: [(Id, Int)] -> Group -group assocs = - foldr f M.empty assocs - where - f (x, c) t = mul (expg (M.singleton x 1) c) t - --- Function symbols--see foldVar to see the arity of each symbol. -data Symbol - = Text -- Text atom - | Data -- Another text-like atom - | Name -- Principal atom - | Skey -- Symmetric key atom - | Base -- Base of an exponentiated atom - | Ltk -- Long term shared symmetric key - | Akey -- Asymmetric key atom - | Invk -- Inverse of asymmetric key - | Pubk -- Public asymmetric key of a principal - | Genr -- The generator constant for the group - | Exp -- Exponentiation function symbol - | Cat -- Term concatenation - | Enc -- Encryption - deriving (Show, Eq, Ord, Enum, Bounded) - --- A Basic Crypto Algebra Term - -data Term - = I !Id - | C !String - | F !Symbol ![Term] - | G !Group -- An exponent, an Abelian group - deriving (Show, Eq, Ord) - --- Basic terms are introduced by defining a function used to decide if --- a term is well-formed. The context of an occurrence of an identifier --- determines its sort. A term that contains just an identifier and its --- sort information is called a variable. The sort of a variable is --- one of mesg, text, data, name, skey, and akey. - --- Terms that represent variables. -isVar :: Term -> Bool -isVar (I _) = True -- Sort: mesg -isVar (F s [I _]) = - -- Sorts: text, data, name, skey, and akey - s == Text || s == Data || s == Name || s == Skey || s == Akey || s == Base -isVar (G t) = isGroupVar t -isVar _ = False - --- Extract the identifier from a variable -varId :: Term -> Id -varId (I x) = x -varId (F Text [I x]) = x -varId (F Data [I x]) = x -varId (F Name [I x]) = x -varId (F Skey [I x]) = x -varId (F Akey [I x]) = x -varId (F Base [I x]) = x -varId (G t) | isGroupVar t = head $ M.keys t -varId _ = error "Algebra.varId: term not a variable with its sort" - -isMesgVar :: Term -> Bool -isMesgVar (I _) = True -isMesgVar _ = False - --- A list of terms are well-formed if each one has the correct --- structure and every occurrence of an identifier in a term has the --- same sort. Variable environments are used to check the sort --- condition. It maps an identifier to a variable that contains the --- identifier. - --- termsWellFormed u ensures all terms in u use each identifier at the --- same sort, and makes sure every term has the correct structure. -termsWellFormed :: [Term] -> Bool -termsWellFormed u = - loop emptyVarEnv u - where - loop _ [] = True - loop env (t : u) = - case termWellFormed env t of - Nothing -> False - Just env' -> loop env' u - -newtype VarEnv = VarEnv (Map Id Term) deriving Show - -emptyVarEnv :: VarEnv -emptyVarEnv = VarEnv M.empty - --- Check the structure and sort condition. - -termWellFormed :: VarEnv -> Term -> Maybe VarEnv -termWellFormed xts t@(I x) = - extendVarEnv xts x t -- Mesg variable -termWellFormed xts t@(F Text [I x]) = - extendVarEnv xts x t -- Text variable -termWellFormed xts t@(F Data [I x]) = - extendVarEnv xts x t -- Data variable -termWellFormed xts t@(F Name [I x]) = - extendVarEnv xts x t -- Name variable -termWellFormed xts t@(F Skey [I x]) = - extendVarEnv xts x t -- Symmetric key variable -termWellFormed xts (F Skey [F Ltk [I x, I y]]) = - -- Long term shared symmetric key - doubleTermWellFormed xts (F Name [I x]) (F Name [I y]) -termWellFormed xts (F Akey [t]) = -- Asymmetric key terms - case t of - I x -> extendVarEnv xts x (F Akey [I x]) - F Invk [I x] -> extendVarEnv xts x (F Akey [I x]) - F Pubk [I x] -> extendVarEnv xts x (F Name [I x]) - F Pubk [C _, I x] -> extendVarEnv xts x (F Name [I x]) - F Invk [F Pubk [I x]] -> extendVarEnv xts x (F Name [I x]) - F Invk [F Pubk [C _, I x]] -> extendVarEnv xts x (F Name [I x]) - _ -> Nothing -termWellFormed xts (F Base [t]) = - baseVarEnv xts t - where - baseVarEnv xts t@(I x) = - extendVarEnv xts x (F Base [t]) - baseVarEnv xts (F Genr []) = - Just xts - baseVarEnv xts (F Exp [t0, G t1]) = - do - xts <- baseVarEnv xts t0 - termWellFormed xts (G t1) - baseVarEnv _ _ = Nothing -termWellFormed xts (G t) = - foldM expnVarEnv xts (M.keys t) - where - expnVarEnv xts x = - extendVarEnv xts x (groupVar x) -termWellFormed xts (C _) = - Just xts -- Tags -termWellFormed xts (F Cat [t0, t1]) = - doubleTermWellFormed xts t0 t1 -- Concatenation -termWellFormed xts (F Enc [t0, t1]) = - doubleTermWellFormed xts t0 t1 -- Encryption -termWellFormed _ _ = Nothing - --- Extend when sorts agree -extendVarEnv :: VarEnv -> Id -> Term -> Maybe VarEnv -extendVarEnv (VarEnv env) x t = - case M.lookup x env of - Nothing -> Just $ VarEnv $ M.insert x t env - Just t' -> if t == t' then Just (VarEnv env) else Nothing - -doubleTermWellFormed :: VarEnv -> Term -> Term -> Maybe VarEnv -doubleTermWellFormed xts t0 t1 = - do - xts <- termWellFormed xts t0 - termWellFormed xts t1 - --- Is the sort of the term a base sort? -isAtom :: Term -> Bool -isAtom (I _) = False -isAtom (C _) = False -isAtom (F s _) = - s == Text || s == Data || s == Name || s == Skey || s == Akey -isAtom (G _) = True - --- Does a term occur in another term? -occursIn :: Term -> Term -> Bool -occursIn (G t) (G t') = - all f (M.assocs t) - where - f (x, n) = - let n' = M.findWithDefault 0 x t' in - n > 0 && n' >= n || n < 0 && n' <= n -occursIn t t' = - t == t' || - case t' of - F _ u -> any (occursIn t) u - _ -> False - --- Fold f through a term applying it to each variable in the term. -foldVars :: (a -> Term -> a) -> a -> Term -> a -foldVars f acc t@(I _) = f acc t -- Mesg variable -foldVars f acc t@(F Text [I _]) = f acc t -- Text variable -foldVars f acc t@(F Data [I _]) = f acc t -- Data variable -foldVars f acc t@(F Name [I _]) = f acc t -- Name variable -foldVars f acc t@(F Skey [I _]) = - f acc t -- Symmetric key variable -foldVars f acc (F Skey [F Ltk [I x, I y]]) = - -- Long term shared symmetric key - f (f acc (F Name [I x])) (F Name [I y]) -foldVars f acc t@(F Akey [I _]) = f acc t -- Asymmetric keys -foldVars f acc (F Akey [F Invk [I x]]) = f acc (F Akey [I x]) -foldVars f acc (F Akey [F Pubk [I x]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Pubk [C _, I x]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Invk [F Pubk [I x]]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Invk [F Pubk [C _, I x]]]) = f acc (F Name [I x]) -foldVars f acc (F Base [t]) = - baseAddVars acc t - where - baseAddVars acc t@(I _) = - f acc (F Base [t]) - baseAddVars acc (F Genr []) = - acc - baseAddVars acc (F Exp [t0, G t1]) = - foldVars f (baseAddVars acc t0) (G t1) - baseAddVars _ _ = error "Algebra.foldVars: Bad term" -foldVars f acc (G t) = - foldl expnAddVars acc (M.keys t) - where - expnAddVars acc x = - f acc (groupVar x) -foldVars _ acc (C _) = acc -- Tags -foldVars f acc (F Cat [t0, t1]) = -- Concatenation - foldVars f (foldVars f acc t0) t1 -foldVars f acc (F Enc [t0, t1]) = -- Encryption - foldVars f (foldVars f acc t0) t1 -foldVars _ _ t = error $ "Algebra.foldVars: Bad term " ++ show t - --- Fold f through a term applying it to each term that is carried by the term. -foldCarriedTerms :: (a -> Term -> a) -> a -> Term -> a -foldCarriedTerms f acc t@(F Cat [t0, t1]) = -- Concatenation - foldCarriedTerms f (foldCarriedTerms f (f acc t) t0) t1 -foldCarriedTerms f acc t@(F Enc [t0, _]) = -- Encryption - foldCarriedTerms f (f acc t) t0 -foldCarriedTerms f acc t = f acc t -- Exponents, atoms, and tags - --- Is a term carried by another term? -carriedBy :: Term -> Term -> Bool -carriedBy t t' = - t == t' || - case t' of - F Cat [t0, t1] -> carriedBy t t0 || carriedBy t t1 - F Enc [t0, _] -> carriedBy t t0 - _ -> False - --- The key used to decrypt an encrypted term, otherwise Nothing. -decryptionKey :: Term -> Maybe Term -decryptionKey (F Enc [_, t]) = Just (inv t) -decryptionKey _ = Nothing - -buildable :: Set Term -> Set Term -> Term -> Bool -buildable knowns unguessable term = - ba term - where - ba (I _) = True -- A mesg sorted variable is always buildable - ba (F Base [I _]) = True -- as is a base sorted variable - ba (C _) = True -- So is a tag - ba (F Cat [t0, t1]) = - ba t0 && ba t1 - ba t@(F Enc [t0, t1]) = - S.member t knowns || ba t0 && ba t1 - ba (F Base [t]) = bb t - ba t = isAtom t && not (S.member t unguessable) - -- Buildable base term - bb (I _) = True -- A variable of sort base is always buildable - bb (F Genr []) = True -- and so in the generator - bb t@(F Exp [t0, G t1]) = - S.member (F Base [t]) knowns || ba t0 && be t1 - bb _ = False - -- Buildable exponent - be t = buildableExponent t - [ g | t <- S.elems unguessable, g <- getGroup t ] - -getGroup :: Term -> [Group] -getGroup (G t) = [t] -getGroup _ = [] - --- BROKEN. VERY BROKEN - --- Just try all the possibilities. -buildableExponent :: Group -> [Group] -> Bool -buildableExponent t unguessables = - elem t (filteredLevel size) - where - size = sum (0 : M.elems t) - filteredLevel n = L.filter (flip notElem unguessables) (level n) - level n | n <= 0 = [] - | n == 1 = usefulKnowns - | otherwise = - usefulKnowns ++ [ mul k k' | - k <- usefulKnowns, - k' <- filteredLevel (n - 1) ] - usefulKnowns = L.filter (flip notElem unguessables) - (map (flip M.singleton 1) (M.keys t)) - --- Compute the decomposition given some known terms and some unguessable --- atoms. The code is quite tricky. It iterates until the known --- terms don't change. The known terms ends up with all the --- encryptions that are known. -decompose :: Set Term -> Set Term -> (Set Term, Set Term) -decompose knowns unguessable = - loop unguessable knowns S.empty [] - where - loop unguessable knowns old [] - | old == knowns = (knowns, unguessable) -- Done - | otherwise = loop unguessable knowns knowns (S.elems knowns) - loop unguessable knowns old (t@(F Cat _) : todo) = - loop unguessable (decat t (S.delete t knowns)) old todo - loop unguessable knowns old ((F Enc [t0, t1]) : todo) - | buildable knowns unguessable (inv t1) = -- Add plaintext - loop unguessable (decat t0 knowns) old todo - | otherwise = loop unguessable knowns old todo - -- New case here: don't delete exponentiated values - loop unguessable knowns old (F Base [F Exp [_, _]] : todo) = - loop unguessable knowns old todo - loop unguessable knowns old (t : todo) = - loop (S.delete t unguessable) (S.delete t knowns) old todo - -- Decat - decat (F Cat [t0, t1]) s = decat t1 (decat t0 s) - decat t s = S.insert t s - --- Inverts an asymmetric key -inv :: Term -> Term -inv (F Akey [F Invk [t]]) = F Akey [t] -inv (F Akey [t]) = F Akey [F Invk [t]] -inv (I _) = error "Algebra.inv: Cannot invert a variable of sort mesg" -inv t = t - --- Extracts every encryption that is carried by a term along with its --- encryption key. -encryptions :: Term -> [(Term, [Term])] -encryptions t = - reverse $ loop t [] - where - loop (F Cat [t, t']) acc = - loop t' (loop t acc) - loop t@(F Enc [t', t'']) acc = - loop t' (adjoin (t, [t'']) acc) - loop t@(F Base [F Exp [_, G t'']]) acc = - adjoin (t, map groupVar (M.keys t'')) acc - loop _ acc = acc - adjoin x xs - | x `elem` xs = xs - | otherwise = x : xs - --- Returns the encryptions that carry the target. If the target is --- carried outside all encryptions, or is exposed because a decription --- key is derivable, Nothing is returned. -protectors :: (Term -> Bool) -> Term -> Term -> Maybe [Term] -protectors derivable target source = - do - ts <- bare source S.empty - return $ S.elems ts - where - bare source _ - | source == target = Nothing - bare (F Cat [t, t']) acc = - maybe Nothing (bare t') (bare t acc) - bare t@(F Enc [t', key]) acc = - if target `carriedBy` t' then - if derivable (inv key) then - bare t' acc - else - Just (S.insert t acc) - else - Just acc - bare t@(F Base [F Exp [_, t'']]) acc - | target == t'' = Just (S.insert t acc) - bare _ acc = Just acc - --- Support for data flow analysis of traces. A flow rule maps an --- initial set of atoms and a set of available terms to sets of pairs --- of the same sets. -type FlowRule = (Set Term, Set Term) -> Set (Set Term, Set Term) - --- Combine flow rules sequentially. -comb :: FlowRule -> FlowRule -> FlowRule -comb f g x = - S.fold h S.empty (g x) - where - h a s = S.union (f a) s - --- Analyze a term as a sent term. -outFlow :: Term -> FlowRule -outFlow t a@(_, available) - | S.member t available = S.singleton a -outFlow (I _) _ = S.empty -outFlow (C _) a = S.singleton a -outFlow (F Cat [t0, t1]) a = -- Construct non-atoms - comb (outFlow t1) (outFlow t0) a -outFlow (F Enc [t0, t1]) a = - comb (outFlow t1) (outFlow t0) a -outFlow t (initial, available) = -- Don't look inside atoms - S.singleton (S.insert t initial, S.insert t available) - --- Analyze a term as a received term. -inFlow :: Term -> FlowRule -inFlow (C _) a = S.singleton a -inFlow (F Cat [t0, t1]) a = -- Try to receive components - S.union -- in both orders - (comb (inFlow t1) (inFlow t0) a) - (comb (inFlow t0) (inFlow t1) a) -inFlow t@(F Enc [t0, t1]) (initial, available) = - S.union -- Encryption can be built - (outFlow t (initial, available)) -- or decrypted - (comb (inFlow t0) (outFlow (inv t1)) a) - where -- Derive decryption key first - a = (initial, S.insert t available) -inFlow t (initial, available) = - S.singleton (initial, S.insert t available) - -instance C.Term Term where - isVar = isVar - isMesgVar = isMesgVar - isAtom = isAtom - termsWellFormed = termsWellFormed - occursIn = occursIn - foldVars = foldVars - foldCarriedTerms = foldCarriedTerms - carriedBy = carriedBy - decryptionKey = decryptionKey - decompose = decompose - buildable = buildable - encryptions = encryptions - protectors = protectors - outFlow = outFlow - inFlow = inFlow - loadTerm = loadTerm - --- Places - --- A place names a one subterm within a term. It is a list of --- integers giving a path through a term to that named subterm. Each --- integer in the list identifies the subterm in a function --- application on the path to the named subterm. The integer is the --- index of the subterm in the application's list of terms. - --- The places and replace code fail to find the variable --- (F Akey [I x]) in (F Akey [Invk [I x]]). - -newtype Place = Place [Int] deriving Show - --- Returns the places a variable occurs within a term. -places :: Term -> Term -> [Place] -places var source = - f [] [] source - where - f paths path source - | var == source = Place (reverse path) : paths - f paths path (F _ u) = - g paths path 0 u - f paths path (G t) = - groupPlaces (varId var) paths path 0 (linearize t) - f paths _ _ = paths - g paths _ _ [] = paths - g paths path i (t : u) = - g (f paths (i: path) t) path (i + 1) u - -linearize :: Group -> [Id] -linearize t = - do - (x, n) <- M.assocs t - replicate (if n >= 0 then n else negate n) x - -groupPlaces :: Id -> [Place] -> [Int] -> Int -> [Id] -> [Place] -groupPlaces _ paths _ _ [] = paths -groupPlaces x paths path i (y:ys) = - let paths' = if x == y then - Place (reverse (i : path)) : paths - else paths in - groupPlaces x paths' path (i + 1) ys - --- Returns the places a term is carried by another term. -carriedPlaces :: Term -> Term -> [Place] -carriedPlaces target source = - f [] [] source - where - f paths path source - | target == source = Place (reverse path) : paths - f paths path (F Cat [t, t']) = - f (f paths (0 : path) t) (1 : path) t' - f paths path (F Enc [t, _]) = - f paths (0 : path) t - f paths _ _ = paths - --- Replace a variable within a term at a given place. -replace :: Term -> Place -> Term -> Term -replace var (Place ints) source = - loop ints source - where - loop [] _ = var - loop (i : path) (F s u) = - F s (C.replaceNth (loop path (u !! i)) i u) - loop [i] (G t) = - groupReplace (varId var) i (factors t) - loop _ _ = error "Algebra.replace: Bad path to term" - -factors :: Group -> [(Id, Int)] -factors t = - do - (x, n) <- M.assocs t - case n >= 0 of - True -> replicate n (x, 1) - False -> replicate (negate n) (x, -1) - -groupReplace :: Id -> Int -> [(Id, Int)] -> Term -groupReplace x i factors = - let (_, n) = factors !! i in - G $ group $ C.replaceNth (x, n) i factors - --- Return the ancestors of the term at the given place. -ancestors :: Term -> Place -> [Term] -ancestors source (Place ints) = - loop [] ints source - where - loop ts [] _ = ts - loop ts (i: path) t@(F _ u) = - loop (t : ts) path (u !! i) - loop ts [_] t@(G _) = t : ts - loop _ _ _ = error "Algebra.ancestors: Bad path to term" - -instance C.Place Term Place where - places = places - carriedPlaces = carriedPlaces - replace = replace - ancestors = ancestors - --- Rename the identifiers in a term. Gen keeps the state of the --- renamer. (Question: should alist be replaced by a Map?) -clone :: Gen -> Term -> (Gen, Term) -clone gen t = - (gen', t') - where - (_, gen', t') = cloneTerm ([], gen) t - cloneTerm (alist, gen) t = - case t of -- The association list maps - I x -> -- identifiers to identifier. - case lookup x alist of - Just y -> (alist, gen, I y) - Nothing -> - let (gen', y) = cloneId gen x in - ((x, y) : alist, gen', I y) - C c -> (alist, gen, C c) - F sym u -> - let (alist', gen', u') = - foldl cloneTermList (alist, gen, []) u in - (alist', gen', F sym $ reverse u') - G t -> - let (alist', gen', ts) = - foldl cloneGroupList (alist, gen, []) (M.assocs t) in - (alist', gen', G $ group ts) - cloneTermList (alist, gen, u) t = - let (alist', gen', t') = cloneTerm (alist, gen) t in - (alist', gen', t' : u) - cloneGroupList (alist, gen, ts) (x, n) = - case lookup x alist of - Just y -> (alist, gen, (y, n) : ts) - Nothing -> - let (gen', y) = cloneId gen x in - ((x, y) : alist, gen', (y, n) : ts) - -instance C.Gen Term Gen where - origin = origin - clone = clone - loadVars = loadVars - --- Functions used in both unification and matching - -type IdMap = Map Id Term - -emptyIdMap :: IdMap -emptyIdMap = M.empty - --- Apply a substitution to a term -idSubst :: IdMap -> Term -> Term -idSubst subst (I x) = - M.findWithDefault (I x) x subst -idSubst _ t@(C _) = t -idSubst subst (F Invk [t]) = - case idSubst subst t of - F Invk [t] -> t -- (invk (invk x)) = x - t -> F Invk [t] -idSubst subst (F Exp [t0, G t1]) = - case idSubst subst t0 of -- (exp (exp g x) y) = (exp g (mul x y)) - F Exp [t0', G t1'] -> - idSubst subst (F Exp [t0', G $ mul t1' t1]) - t -> expSubst subst t t1 -idSubst subst (F s u) = - F s (map (idSubst subst) u) -idSubst subst (G t) = - G $ groupSubst subst t - -expSubst :: IdMap -> Term -> Group -> Term -expSubst subst t0 t1 = - case groupSubst subst t1 of - t1' | M.null t1' -> t0 -- (exp g (one)) = g - | otherwise -> F Exp [t0, G t1'] - -groupSubst :: IdMap -> Group -> Group -groupSubst subst t = - M.foldrWithKey f M.empty t - where - f x n t = - mul (expg (groupLookup subst x) n) t - -groupLookup :: IdMap -> Id -> Group -groupLookup subst x = - case M.findWithDefault (groupVar x) x subst of - G t -> t - w -> error ("Algebra.groupLookup: Bad substitution: " ++ - show x ++ " -> " ++ show w) - -showMap :: (Show a, Show b) => Map a b -> ShowS -showMap m = - showAssocs (M.assocs m) - where - showAssocs [] = id - showAssocs ((x,y):m) = - showString "\n " . shows x . showString " -> " . - shows y . showAssocs m - --- Unification and substitution - -newtype Subst = Subst IdMap deriving (Eq, Ord) - -instance Show Subst where - showsPrec _ (Subst s) = showString "Subst (" . showMap s . showChar ')' - -emptySubst :: Subst -emptySubst = Subst emptyIdMap - --- Apply a substitution created by unification -substitute :: Subst -> Term -> Term -substitute (Subst s) t = - idSubst s t - --- Composition of substitutions - --- substitute (compose s0 s1) t = substitute s0 (substitute s1 t) - --- 1. apply s0 to range of s1 to obtain s2; --- 2. remove bindings is s0 where domains of s0 and s1 overlap to form s3; --- 3. remove trivial bindings from s2 to form s4; and --- 4. take the union of s4 and s3. - -compose :: Subst -> Subst -> Subst -compose (Subst s0) (Subst s1) = - let s2 = M.map (substitute (Subst s0)) s1 -- Step 1 - s4 = M.filterWithKey nonTrivialBinding s2 in -- Step 3 - Subst (M.union s4 s0) -- Steps 2 and 4, union is left-biased - -nonTrivialBinding :: Id -> Term -> Bool -nonTrivialBinding x (I y) = x /= y -nonTrivialBinding _ _ = True - --- During unification, variables determined to be equal are collected --- into an equivalence class. Multiple lookups of each variable in --- the internal representation of a substitution finds the canonical --- representive of the class. The chase function finds the current --- canonical representitive. - --- Get the canonical representative of equivalent identifiers making use --- of this algebra's axiom. -chase :: Subst -> Term -> Term -chase (Subst s) (I x) = - case M.lookup x s of - Nothing -> I x - Just t -> chase (Subst s) t -chase s (F Invk [t]) = chaseInvk s t -chase s (F Exp [t0, G t1]) = chaseExp s t0 t1 -chase _ t = t - -chaseInvk :: Subst -> Term -> Term -chaseInvk (Subst s) (I x) = - case M.lookup x s of - Nothing -> F Invk [I x] - Just t -> chaseInvk (Subst s) t -chaseInvk s (F Invk [t]) = chase s t -chaseInvk _ t = F Invk [t] - -chaseExp :: Subst -> Term -> Group -> Term -chaseExp s t0 t1 - | M.null t1 = chase s t0 -chaseExp s (I x) t1 = - case chase s (I x) of - F Exp [t0', G t1'] -> chaseExp s t0' (mul t1 t1') - t0 -> F Exp [t0, G t1] -chaseExp s (F Exp [t0', G t1']) t1 = - chaseExp s t0' (mul t1 t1') -chaseExp _ t0 t1 = F Exp [t0, G t1] - --- Does x occur in t? -occurs :: Id -> Term -> Bool -occurs x (I y) = x == y -occurs _ (C _) = False -occurs x (F _ u) = any (occurs x) u -occurs x (G t) = elem x (M.keys t) - -type GenSubst = (Gen, Subst) - -unifyChase :: Term -> Term -> GenSubst -> Maybe GenSubst -unifyChase t t' (g, s) = unifyTerms (chase s t) (chase s t') (g, s) - -unifyTerms :: Term -> Term -> GenSubst -> Maybe GenSubst -unifyTerms (I x) (I y) (g, Subst s) - | x == y = Just (g, Subst s) - | otherwise = Just (g, Subst $ M.insert x (I y) s) -unifyTerms (I x) t (g, Subst s) - | occurs x t = Nothing - | otherwise = Just (g, Subst $ M.insert x t s) -unifyTerms t (I x) s = unifyTerms (I x) t s -unifyTerms (C c) (C c') s - | c == c' = Just s - | otherwise = Nothing -unifyTerms (F Invk [I x]) (F Pubk [I y]) s = - unifyTerms (I x) (F Invk [F Pubk [I y]]) s -unifyTerms (F Invk [I x]) (F Pubk [C c, I y]) s = - unifyTerms (I x) (F Invk [F Pubk [C c, I y]]) s -unifyTerms (F Pubk [I x]) (F Invk [I y]) s = - unifyTerms (I y) (F Invk [F Pubk [I x]]) s -unifyTerms (F Pubk [C c, I x]) (F Invk [I y]) s = - unifyTerms (I y) (F Invk [F Pubk [C c, I x]]) s -unifyTerms (F Exp [t0, G t1]) (F Exp [t0', G t1']) s = - unifyExp t0 t1 t0' t1' s -unifyTerms (F sym u) (F sym' u') s - | sym == sym' = unifyTermLists u u' s - | otherwise = Nothing -unifyTerms (G t) (G t') s = - Just $ unifyGroup t t' s -unifyTerms _ _ _ = Nothing - -unifyExp :: Term -> Group -> Term -> Group -> GenSubst -> Maybe GenSubst -unifyExp t0 t1 t0' t1' s - | t0 == t0' = Just $ unifyGroup t1 t1' s -unifyExp (I x) t1 t0' t1' (g, Subst s) = - unifyExp (F Genr []) v t0' t1' (g', Subst s') - where - (g', id) = freshId g "x" - v = mul t1 $ M.singleton id 1 - s' = M.insert x (F Exp [F Genr [], G v]) s -unifyExp (F Genr []) t1 (I x) t1' s = - unifyExp (I x) t1' (F Genr []) t1 s -unifyExp _ _ _ _ _ = Nothing - -unifyTermLists :: [Term] -> [Term] -> GenSubst -> Maybe GenSubst -unifyTermLists [] [] s = Just s -unifyTermLists (t : u) (t' : u') s = - maybe Nothing (unifyTermLists u u') (unifyChase t t' s) -unifyTermLists _ _ _ = Nothing - -unifyGroup :: Group -> Group -> GenSubst -> GenSubst -unifyGroup t0 t1 (g, Subst s) = - case M.assocs (groupSubst s $ mul t0 $ invert t1) of - [] -> - (g, Subst s) - t -> - let bases = D.linDiophEq (map snd t) 0 in - mkmgus (map fst t) bases (g, Subst s) - -mkmgus :: [Id] -> [[Int]] -> GenSubst -> GenSubst -mkmgus vars [] (g, Subst s) = - (g, Subst $ foldl f s vars) - where - f s v = M.insert v (G M.empty) s -mkmgus vars bases (g, Subst s) = - (g'', Subst (foldr bind s (zip vars terms))) - where - trans = L.transpose bases - -- Create a variable for each element of a row - (g'', vars') = foldr genv (g, []) (head trans) - -- Generate one variable (the first argument is used just to count) - genv _ (g, vs) = (g', v:vs) where (g', v) = freshId g "u" - -- Construct the terms from freshly generated variables - terms = map (G . group . zip vars') trans - -- Bind a variable to a term - bind (v, t) s = M.insert v t s - --- The exported unifier converts the internal representation of a --- substitution into the external form using chaseMap. - -unify :: Term -> Term -> GenSubst -> Maybe GenSubst -unify t t' s = - do - (g, s) <- unifyChase t t' s - return (g, chaseMap s) - --- Apply the chasing version of substitution to the range of s. - -chaseMap :: Subst -> Subst -chaseMap (Subst s) = - Subst $ M.map (substChase (Subst s)) s - --- A chasing version of substitution. - -substChase :: Subst -> Term -> Term -substChase subst t = - case chase subst t of - t@(I _) -> t - t@(C _) -> t - F Invk [t] -> - case substChase subst t of - F Invk [t] -> t -- Apply axiom - t -> F Invk [t] - F Exp [t0, G t1] -> - case substChase subst t0 of - F Exp [t0', G t1'] -> - substChase subst (F Exp [t0', G $ mul t1' t1]) - t -> expChase subst t t1 - F s u -> - F s (map (substChase subst) u) - G t -> G $ groupChase subst t - -expChase :: Subst -> Term -> Group -> Term -expChase subst t0 t1 = - case groupChase subst t1 of - t1' | M.null t1' -> t0 - | otherwise -> F Exp [t0, G t1'] - -groupChase :: Subst -> Group -> Group -groupChase (Subst subst) t = - loop t - where - loop t = - case groupSubst subst t of - t' | t == t' -> t' - | otherwise -> loop t' - -instance C.Subst Term Gen Subst where - emptySubst = emptySubst - substitute = substitute - unify t t' s = maybe [] (: []) $ unify t t' s - compose = compose - --- Matching and instantiation - -newtype Env = Env IdMap deriving (Eq, Ord) - -instance Show Env where - showsPrec _ (Env r) = - showString "Env (" . showMap r . showChar ')' - --- An environment may contain an explicit identity mapping, whereas a --- substitution is erroneous if it has one. - -emptyEnv :: Env -emptyEnv = Env emptyIdMap - --- Apply a substitution created my matching -instantiate :: Env -> Term -> Term -instantiate (Env r) t = idSubst r t - --- Matching - --- The matcher has the property that when pattern P and term T match --- then instantiate (match P T emptyEnv) P = T. -match :: Term -> Term -> Env -> [Env] -match (I x) t (Env r) = - case M.lookup x r of - Nothing -> [Env (M.insert x t r)] - Just t' -> if t == t' then [Env r] else [] -match (C c) (C c') r = if c == c' then [r] else [] -match (F Exp [t0, G t1]) (F Exp [t0', G t1']) r - = matchExp t0 t1 t0' t1' r -match (F s u) (F s' u') r - | s == s' = matchLists u u' r -match (F Invk [t]) t' r = - match t (F Invk [t']) r -match (G t) (G t') (Env r) = - do - let (t0, t0') = merge t t' r - r' <- matchGroup t0 t0' - return (Env $ M.union r' r) -match _ _ _ = [] - -matchExp :: Term -> Group -> Term -> Group -> Env -> [Env] -matchExp (I x) t1 t0' t1' r@(Env e) = - case M.lookup x e of - Just (F Exp [t0'', G t1'']) - | t0' == t0'' -> match (G t1) (G (mul t1' (invert t1''))) r - _ -> matchLists [I x, G t1] [t0', G t1'] r -matchExp (F Genr []) t1 t0' t1' r = - matchLists [F Genr [], G t1] [t0', G t1'] r -matchExp _ _ _ _ _ = error "Algebra.matchExp: Bad match term" - -matchLists :: [Term] -> [Term] -> Env -> [Env] -matchLists [] [] r = [r] -matchLists (t : u) (t' : u') r = - do - r' <- match t t' r - matchLists u u' r' -matchLists _ _ _ = [] - --- Merge the results of applying the env to the left-hand side. -merge :: Group -> Group -> IdMap -> (Group, Group) -merge t t' r = - (group t0, t0') - where - (t0, t0') = loop (M.assocs t) ([], t') - loop [] acc = acc - loop (p@(x, n) : t0) (t1, t1') = - case M.lookup x r of - Nothing -> loop t0 (p : t1, t1') - Just (G t) -> - loop t0 (t1, mul (expg t (negate n)) t1') - Just t -> - error $ "Algebra.merge: expecting an expn but got " ++ show t - --- To perform matching in a Commutative Monoid, one must solve a --- linear Diophantine equation. For matching, the coefficients of the --- equation are always positive, so there are no solutions the --- homegeneous problem. That means there is no need to generate fresh --- variables as is required when performing matching in an Abelian --- Group. - --- The substitions are sorted in an effort to favor mappings that --- represent renamings. -matchGroup :: Group -> Group -> [IdMap] -matchGroup t0 t1 = - map (M.map G) $ sortMaps $ solveLinEqs (M.assocs t0) (M.assocs t1) - -type Coeff = [(Id, Int)] -type IdGrpMap = Map Id Group - --- Variables on the RHS are treated as constants. This routine --- produces solutions that satisfy each variable on the RHS and merges --- the solutions. -solveLinEqs :: Coeff -> Coeff -> [IdGrpMap] -solveLinEqs lhs [] = - [M.fromList (map (\(v, _) -> (v, M.empty)) lhs)] -solveLinEqs lhs ((v, c):rhs) = - [ M.unionWith mul env env' | - env <- solveLinEq lhs v c, - env' <- solveLinEqs lhs rhs ] - --- Solve the linear Diophantine equation for one variable on the RHS. -solveLinEq :: Coeff -> Id -> Int -> [IdGrpMap] -solveLinEq lhs var multiplicity = - [ foldl toEnv M.empty (zip (map fst lhs) (tail solution)) - | solution <- D.linDiophEq (map snd lhs) multiplicity ] - where - toEnv env (v', 0) = -- Map v' to one - M.insert v' M.empty env - toEnv env (v', c) = -- Map v' to (mul var ...) c times - M.insert v' (M.singleton var c) env - --- The maps are sorted in that mappings that represent renamings are --- preferred. -sortMaps :: [IdGrpMap] -> [IdGrpMap] -sortMaps envs = - L.sortBy cmp envs - where - cmp e0 e1 = compare (measure e0) (measure e1) - measure e = - if M.null e then - 0 - else - maximum (map (sum . M.elems) (M.elems e)) - --- Does every varible in ts not occur in the domain of e? --- Trivial bindings in e are ignored. -identityEnvFor :: Env -> [Term] -> [Env] -identityEnvFor ge ts = - let env@(Env r) = nonTrivialEnv ge in - if all (allId $ flip S.notMember $ M.keysSet r) ts then - [env] - else - [] - -allId :: (Id -> Bool) -> Term -> Bool -allId f (I x) = f x -allId _ (C _) = True -allId f (F _ u) = all (allId f) u -allId f (G t) = all f (M.keys t) - --- Eliminate all trivial bindings so that an environment can be used --- as a substitution. -nonTrivialEnv :: Env -> Env -nonTrivialEnv (Env r) = - nonGroupEnv (M.assocs r) M.empty - where - nonGroupEnv [] env = - Env env - nonGroupEnv ((x, I y):r) env - | x == y = nonGroupEnv r env - nonGroupEnv ((x, G y):r) env - | isGroupVar y && varId (G y) == x = - nonGroupEnv r env - nonGroupEnv ((x, y):r) env = - nonGroupEnv r (M.insert x y env) - --- Cast an environment into a substitution by filtering out trivial --- bindings. - -substitution :: Env -> Subst -substitution (Env r) = - Subst $ M.filterWithKey nonTrivialBinding r - --- Add type information to an environment, and return it as a list of --- associations. - -reify :: [Term] -> Env -> [(Term, Term)] -reify domain (Env env) = - map (loop domain) $ M.assocs env - where - loop [] (x, _) = - error $ "Algebra.reify: variable missing from domain " ++ idName x - loop (I x : _) (y, t) - | x == y = (I x, t) - loop (F Text [I x] : _) (y, t) - | x == y = (F Text [I x], F Text [t]) - loop (F Data [I x] : _) (y, t) - | x == y = (F Data [I x], F Data [t]) - loop (F Name [I x] : _) (y, t) - | x == y = (F Name [I x], F Name [t]) - loop (F Skey [I x] : _) (y, t) - | x == y = (F Skey [I x], F Skey [t]) - loop (F Akey [I x] : _) (y, t) - | x == y = (F Akey [I x], F Akey [t]) - loop (F Base [I x] : _) (y, t) - | x == y = (F Base [I x], F Base [t]) - loop (G x : _) (y, G t) - | isGroupVar x && varId (G x) == y = (G x, G t) - loop (_ : domain) pair = loop domain pair - --- Ensure the range of an environment contains only variables and that --- the environment is injective. -matchRenaming :: Env -> Bool -matchRenaming (Env e) = - nonGrp S.empty (M.elems e) - where - nonGrp _ [] = True - nonGrp s (I x:e) | not (S.member x s) = - nonGrp (S.insert x s) e - nonGrp s (G x:e) | isGroupVar x && not (S.member (varId $ G x) s) = - nonGrp (S.insert (varId $ G x) s) e - nonGrp _ _ = False - -instance C.Env Term Gen Subst Env where - emptyEnv = emptyEnv - instantiate = instantiate - match t t' (g, e) = - map (\e -> (g, e)) $ match t t' e - identityEnvFor (g, e) t = map (\e -> (g, e)) $ identityEnvFor e t - specialize = id - substitution = substitution - reify = reify - matchRenaming (_, e) = matchRenaming e - --- Term specific loading functions - -loadVars :: Monad m => Gen -> [SExpr Pos] -> m (Gen, [Term]) -loadVars gen sexprs = - do - pairs <- mapM loadVarPair sexprs - (g, vars) <- foldM loadVar (gen, []) (concat pairs) - return (g, reverse vars) - -loadVarPair :: Monad m => SExpr Pos -> m [(SExpr Pos, SExpr Pos)] -loadVarPair (L _ (x:xs)) = - let (t:vs) = reverse (x:xs) in - return [(v,t) | v <- reverse vs] -loadVarPair x = fail (shows (annotation x) "Bad variable declaration") - -loadVar :: Monad m => (Gen, [Term]) -> (SExpr Pos, SExpr Pos) -> - m (Gen, [Term]) -loadVar (gen, vars) (S pos name, S pos' sort) = - case loadLookup pos vars name of - Right _ -> - fail (shows pos "Duplicate variable declaration for " ++ name) - Left _ -> - do - let (gen', x) = freshId gen name - p <- mkVar x - return (gen', p : vars) - where - mkVar x = - let t = I x in - case sort of - "mesg" -> return t - "text" -> return $ F Text [t] - "data" -> return $ F Data [t] - "name" -> return $ F Name [t] - "skey" -> return $ F Skey [t] - "akey" -> return $ F Akey [t] - "base" -> return $ F Base [t] - "expn" -> return $ groupVar x - _ -> fail (shows pos' "Sort " ++ sort ++ " not recognized") -loadVar _ (x,_) = fail (shows (annotation x) "Bad variable syntax") - -loadLookup :: Pos -> [Term] -> String -> Either String Term -loadLookup pos [] name = Left (shows pos $ "Identifier " ++ name ++ " unknown") -loadLookup pos (t : u) name = - let name' = idName (varId t) in - if name' == name then Right t else loadLookup pos u name - -loadLookupName :: Monad m => Pos -> [Term] -> String -> m Term -loadLookupName pos vars name = - either fail f (loadLookup pos vars name) - where - f t@(F Name [I _]) = return t - f _ = fail (shows pos $ "Expecting " ++ name ++ " to be a name") - -loadLookupAkey :: Monad m => Pos -> [Term] -> String -> m Term -loadLookupAkey pos vars name = - either fail f (loadLookup pos vars name) - where - f t@(F Akey [I _]) = return t - f _ = fail (shows pos $ "Expecting " ++ name ++ " to be an akey") - --- Load term and check that it is well-formed. -loadTerm :: Monad m => [Term] -> SExpr Pos -> m Term -loadTerm vars (S pos s) = - either fail return (loadLookup pos vars s) -loadTerm _ (Q _ t) = - return (C t) -loadTerm vars (L pos (S _ s : l)) = - case lookup s loadDispatch of - Nothing -> fail (shows pos "Keyword " ++ s ++ " unknown") - Just f -> f pos vars l -loadTerm _ x = fail (shows (annotation x) "Malformed term") - -type LoadFunction m = Pos -> [Term] -> [SExpr Pos] -> m Term - -loadDispatch :: Monad m => [(String, LoadFunction m)] -loadDispatch = - [("pubk", loadPubk) - ,("privk", loadPrivk) - ,("invk", loadInvk) - ,("ltk", loadLtk) - ,("gen", loadGen) - ,("exp", loadExp) - ,("one", loadOne) - ,("mul", loadMul) - ,("cat", loadCat) - ,("enc", loadEnc) - ] - --- Atom constructors: pubk privk invk ltk - -loadPubk :: Monad m => LoadFunction m -loadPubk _ vars [S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Pubk [I $ varId t]] -loadPubk _ vars [Q _ c, S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Pubk [C c, I $ varId t]] -loadPubk pos _ _ = fail (shows pos "Malformed pubk") - -loadPrivk :: Monad m => LoadFunction m -loadPrivk _ vars [S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Invk [F Pubk [I $ varId t]]] -loadPrivk _ vars [Q _ c, S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Invk [F Pubk [C c, I $ varId t]]] -loadPrivk pos _ _ = fail (shows pos "Malformed privk") - -loadInvk :: Monad m => LoadFunction m -loadInvk _ vars [S pos s] = - do - t <- loadLookupAkey pos vars s - return $ F Akey [F Invk [I $ varId t]] -loadInvk pos _ _ = fail (shows pos "Malformed invk") - -loadLtk :: Monad m => LoadFunction m -loadLtk _ vars [S pos s, S pos' s'] = - do - t <- loadLookupName pos vars s - t' <- loadLookupName pos' vars s' - return $ F Skey [F Ltk [I $ varId t, I $ varId t']] -loadLtk pos _ _ = fail (shows pos "Malformed ltk") - --- Base and exponents - -loadGen :: Monad m => LoadFunction m -loadGen _ _ [] = - return $ F Base [F Genr []] -loadGen pos _ _ = fail (shows pos "Malformed gen") - -loadExp :: Monad m => LoadFunction m -loadExp _ vars [x, x'] = - do - t <- loadBase vars x - t' <- loadExpn vars x' - return $ F Base [idSubst emptyIdMap $ F Exp [t, G t']] -loadExp pos _ _ = fail (shows pos "Malformed exp") - -loadBase :: Monad m => [Term] -> SExpr Pos -> m Term -loadBase vars x = - do - t <- loadTerm vars x - case t of - F Base [t] -> return t - _ -> fail (shows (annotation x) "Malformed base") - -loadExpn :: Monad m => [Term] -> SExpr Pos -> m Group -loadExpn vars x = - do - t <- loadTerm vars x - case t of - G t -> return t - _ -> fail (shows (annotation x) "Malformed expn") - -loadOne :: Monad m => LoadFunction m -loadOne _ _ [] = - return $ G M.empty -loadOne pos _ _ = fail (shows pos "Malformed one") - -loadMul :: Monad m => LoadFunction m -loadMul _ vars xs = - do - t <- foldM f M.empty xs - return $ G t - where - f acc x = - do - t <- loadExpn vars x - return $ mul t acc - --- Term constructors: cat enc - -loadCat :: Monad m => LoadFunction m -loadCat _ vars (l : ls) = - do - ts <- mapM (loadTerm vars) (l : ls) - return $ foldr1 (\a b -> F Cat [a, b]) ts -loadCat pos _ _ = fail (shows pos "Malformed cat") - -loadEnc :: Monad m => LoadFunction m -loadEnc pos vars (l : l' : ls) = - do - let (butLast, last) = splitLast l (l' : ls) - t <- loadCat pos vars butLast - t' <- loadTerm vars last - return $ F Enc [t, t'] -loadEnc pos _ _ = fail (shows pos "Malformed enc") - -splitLast :: a -> [a] -> ([a], a) -splitLast x xs = - loop [] x xs - where - loop z x [] = (reverse z, x) - loop z x (y : ys) = loop (x : z) y ys - --- Term specific displaying functions - -newtype Context = Context [(Id, String)] deriving Show - -displayVars :: Context -> [Term] -> [SExpr ()] -displayVars _ [] = [] -displayVars ctx vars = - let (v,t):pairs = map (displayVar ctx) vars in - loop t [v] pairs - where - loop t vs [] = [L () (reverse (t:vs))] - loop t vs ((v',t'):xs) - | t == t' = loop t (v':vs) xs - | otherwise = L () (reverse (t:vs)):loop t' [v'] xs - -displayVar :: Context -> Term -> (SExpr (), SExpr ()) -displayVar ctx (I x) = displaySortId "mesg" ctx x -displayVar ctx (F Text [I x]) = displaySortId "text" ctx x -displayVar ctx (F Data [I x]) = displaySortId "data" ctx x -displayVar ctx (F Name [I x]) = displaySortId "name" ctx x -displayVar ctx (F Skey [I x]) = displaySortId "skey" ctx x -displayVar ctx (F Akey [I x]) = displaySortId "akey" ctx x -displayVar ctx (F Base [I x]) = displaySortId "base" ctx x -displayVar ctx t@(G x) - | isGroupVar x = displaySortId "expn" ctx (varId t) -displayVar _ _ = - error "Algebra.displayVar: term not a variable with its sort" - -displaySortId :: String -> Context -> Id -> (SExpr (), SExpr ()) -displaySortId sort ctx x = (displayId ctx x, S () sort) - -displayId :: Context -> Id -> SExpr () -displayId (Context ctx) x = - case lookup x ctx of - Nothing -> - let msg = idName x ++ " in a display context" in - error $ "Algebra.displayId: Cannot find variable " ++ msg - Just name -> S () name - -displayTerm :: Context -> Term -> SExpr () -displayTerm ctx (I x) = displayId ctx x -displayTerm ctx (F Text [I x]) = displayId ctx x -displayTerm ctx (F Data [I x]) = displayId ctx x -displayTerm ctx (F Name [I x]) = displayId ctx x -displayTerm ctx (F Skey [I x]) = displayId ctx x -displayTerm ctx (F Skey [F Ltk [I x, I y]]) = - L () [S () "ltk", displayId ctx x, displayId ctx y] -displayTerm ctx (F Akey [t]) = - case t of - I x -> displayId ctx x - F Invk [I x] -> L () [S () "invk", displayId ctx x] - F Pubk [I x] -> L () [S () "pubk", displayId ctx x] - F Pubk [C c, I x] -> L () [S () "pubk", Q () c, displayId ctx x] - F Invk [F Pubk [I x]] -> L () [S () "privk", displayId ctx x] - F Invk [F Pubk [C c, I x]] -> - L () [S () "privk", Q () c, displayId ctx x] - _ -> error ("Algebra.displayAkey: Bad term " ++ show t) -displayTerm ctx (F Base [t]) = - displayBase t - where - displayBase (I x) = displayId ctx x - displayBase (F Genr []) = - L () [S () "gen"] - displayBase (F Exp [t0, G t1]) = - L () [S () "exp", displayBase t0, displayTerm ctx (G t1)] - displayBase t = error ("Algebra.displayBase: Bad term " ++ show t) -displayTerm ctx (G t) = - displayExpn t - where - displayExpn t - | M.null t = L () [S () "one"] - | otherwise = - case factors t of - [f] -> displayFactor f - fs -> L () (S () "mul" : map displayFactor fs) - displayFactor (x, n) - | n >= 0 = displayId ctx x - | otherwise = error ("Algebra.displayTerm: Bad factor " ++ show t) -displayTerm _ (C t) = Q () t -displayTerm ctx (F Cat [t0, t1]) = - L () (S () "cat" : displayTerm ctx t0 : displayList ctx t1) -displayTerm ctx (F Enc [t0, t1]) = - L () (S () "enc" : displayEnc ctx t0 t1) -displayTerm _ t = error ("Algebra.displayTerm: Bad term " ++ show t) - -displayList :: Context -> Term -> [SExpr ()] -displayList ctx (F Cat [t0, t1]) = displayTerm ctx t0 : displayList ctx t1 -displayList ctx t = [displayTerm ctx t] - -displayEnc :: Context -> Term -> Term -> [SExpr ()] -displayEnc ctx (F Cat [t0, t1]) t = displayTerm ctx t0 : displayEnc ctx t1 t -displayEnc ctx t0 t1 = [displayTerm ctx t0, displayTerm ctx t1] - -displayEnv :: Context -> Context -> Env -> [SExpr ()] -displayEnv ctx ctx' (Env r) = - map (\(x, t) -> L () [displayTerm ctx x, displayTerm ctx' t]) r' - where - r' = map (\(x, t) -> (I x, inferSort t)) $ M.assocs r - --- displaySubst c s displays a substitution s in context c, where some --- variables that occur in s might not be in c. Enough sort --- inference is performed so as to allow the extension of the context. -displaySubst :: Context -> Subst -> [SExpr ()] -displaySubst ctx s@(Subst r) = - map (\(x, t) -> L () [displayTerm ctx' x, displayTerm ctx' t]) r' - where - r' = map (\(x, t) -> (I x, inferSort (substitute s t))) $ M.assocs r - ctx' = foldl (\ctx (x, t) -> addToContext ctx [x, t]) ctx r' - -inferSort :: Term -> Term -inferSort t@(F Invk _) = F Akey [t] -inferSort t@(F Pubk _) = F Akey [t] -inferSort t@(F Ltk _) = F Skey [t] -inferSort t@(F Genr _) = F Base [t] -inferSort t@(F Exp _) = F Base [t] -inferSort t = t - -emptyContext :: Context -emptyContext = Context [] - --- Generate names for output renaming as necessary. --- Assumes the input is a list of term that are well-formed -addToContext :: Context -> [Term] -> Context -addToContext ctx u = - foldl (foldVars varContext) ctx u - -varContext :: Context -> Term -> Context -varContext ctx t = - let x = varId t - name = rootName $ idName x in - if hasId ctx x then - ctx - else - if hasName ctx name then - extendContext ctx x (genName ctx name) - else - extendContext ctx x name - -hasId :: Context -> Id -> Bool -hasId (Context ctx) id = - maybe False (const True) (lookup id ctx) - -hasName :: Context -> String -> Bool -hasName (Context ctx) name = - maybe False (const True) (L.find ((name ==) . snd) ctx) - -extendContext :: Context -> Id -> String -> Context -extendContext (Context ctx) x name = - Context $ (x, name) : ctx - -genName :: Context -> String -> String -genName ctx name = - loop 0 - where - root = '-' : reverse name - loop :: Int -> String - loop n = - let name' = revapp root (show n) in - if hasName ctx name' then - loop (n + 1) - else - name' - revapp [] s = s - revapp (c : cs) s = revapp cs (c : s) - -rootName :: String -> String -rootName name = - noHyphen 0 name - where - noHyphen _ [] = name - noHyphen i (c : s) - | c == '-' = hyphen i (i + 1) s - | otherwise = noHyphen (i + 1) s - hyphen i _ [] = rootName $ take i name - hyphen i j (c : s) - | isDigit c = hyphen i (j + 1) s - | otherwise = noHyphen j (c : s) - -instance C.Context Term Gen Subst Env Context where - emptyContext = emptyContext - addToContext = addToContext - displayVars = displayVars - displayTerm = displayTerm - displayEnv = displayEnv - displaySubst = displaySubst - -instance C.Algebra Term Place Gen Subst Env Context diff --git a/src/CPSA/DiffieHellmanNoReciprocal/LinDiophEq.hs b/src/CPSA/DiffieHellmanNoReciprocal/LinDiophEq.hs deleted file mode 100644 --- a/src/CPSA/DiffieHellmanNoReciprocal/LinDiophEq.hs +++ /dev/null @@ -1,168 +0,0 @@ --- Linear Diophantine Equation solver --- --- Copyright (c) 2009 The MITRE Corporation --- --- This program is free software: you can redistribute it and/or --- modify it under the terms of the BSD License as published by the --- University of California. - --- | --- Module : CPSA.DiffieHellmanNoReciprocal.LinDiophEq --- Copyright : (C) 2009 John D. Ramsdell --- License : BSD --- --- Linear Diophantine Equation solver. --- --- The solver uses the algorithm of Contejean and Devie as specified --- in \"An Efficient Incremental Algorithm for Solving Systems of --- Linear Diophantine Equations\", Information and Computation --- Vol. 113, pp. 143-174, 1994. --- --- The algorithm for systems of homogeneous linear Diophantine --- equations follows. Let e[k] be the kth basis vector for 1 <= k <= --- n. To find the minimal, non-negative solutions M to the system of --- equations sum(i=1,n,a[i]*v[i]) = 0, the algorithm of Contejean and --- Devie is: --- --- 1. [init] A := {e[k] | 1 <= k <= n}; M := {} --- --- 2. [new minimal results] M := M + {a in A | a is a solution} --- --- 3. [unnecessary branches] A := {a in A | all m in M : some --- 1 <= k <= n : m[k] < a[k]} --- --- 4. [breadth-first search] A := {a + e[k] | a in A, 1 <= k <= n, --- \ \< 0} --- --- 5. [test] If A = {}, stop, else go to 2. --- --- This module provides a solver for a single linear Diophantine --- equation a*v = b, where a and v are vectors, not matrices. --- --- When solving an inhomogeneous equation, it uses the homogeneous --- solver after adding -b as the first element of v and by bounding --- the first element of a to be one at each step in the computation. --- The first element of a solution is zero if it is a solution to the --- associated homogeneous equation, and one if it is a solution to the --- inhomogeneous equation. --- --- The algorithm is likely to be Fortenbacher's algorithm, the one --- generalized to systems of equations by Contejean and Devie, but I --- have not been able to verified this fact. - -module CPSA.DiffieHellmanNoReciprocal.LinDiophEq (linDiophEq) where - -import Data.Array -import Data.Set (Set) -import qualified Data.Set as S - -{-- Debugging hack -import System.IO.Unsafe - -z :: Show a => a -> b -> b -z x y = seq (unsafePerformIO (print x)) y - -zz :: Show a => a -> a -zz x = z x x - -pr :: Set (Vector Int) -> [[Int]] -pr s = map elems $ S.toList s - -zzz :: Set (Vector Int) -> Set (Vector Int) -zzz s = z (pr s) s ---} - -type Vector a = Array Int a - -vector :: Int -> [a] -> Vector a -vector n elems = - listArray (0, n - 1) elems - --- | The 'linDiophEq' function takes a list of integers that specifies --- the coefficients of linear Diophantine equation and a constant, --- and returns the equation's minimal, non-negative solutions. --- --- When solving an inhomogeneous equation, the first element of a --- solution is zero if it solves the associated homogeneous equation, --- and one otherwise. --- --- Thus to solve 2x + y - z = 2, use --- --- @ --- linDiophEq [2,1,-1] 2 = [[0,0,1,1],[1,1,0,0],[0,1,0,2],[1,0,2,0]] --- @ --- --- The two minimal solutions to the homogeneous equation are [0,1,1] --- and [1,0,2], so any linear combinations of these solutions --- contributes to a solution. The solution that corresponds to --- [1,0,0] is x = w + 1, y = v, and z = v + 2w. The solution that --- corresponds to [0,2,0] is x = w, y = v + 2, and z = v + 2w. - -linDiophEq :: [Int] -> Int -> [[Int]] -linDiophEq [] _ = [] -linDiophEq v 0 = - newMinimalResults True (vector n v) (basis n) S.empty - where n = length v -linDiophEq v c = - newMinimalResults False (vector n (negate c:v)) (basis n) S.empty - where n = 1 + length v - --- Construct the basis vectors for an n-dimensional space -basis :: Int -> Set (Vector Int) -basis n = - S.fromList [ z // [(k, 1)] | k <- indices z ] - where z = vector n $ replicate n 0 - --- This is the main loop. - --- Add elements of a that solve the equation to m and the output --- Variable hom is true when solving a homogeneous equation -newMinimalResults :: Bool -> Vector Int -> Set (Vector Int) -> - Set (Vector Int) -> [[Int]] -newMinimalResults _ _ a _ | S.null a = [] -newMinimalResults hom v a m = - loop m (S.toList a) -- Test each element in a - where - loop m [] = -- When done, prepare for next iteration - let a' = unnecessaryBranches a m - a'' = breadthFirstSearch hom v a' in - newMinimalResults hom v a'' m - loop m (x:xs) - | prod v x == 0 && S.notMember x m = - elems x:loop (S.insert x m) xs -- Answer found - | otherwise = - loop m xs - --- Breadth-first search using the algorithm of Contejean and Devie --- Variable hom is true when solving a homogeneous equation -breadthFirstSearch :: Bool -> Vector Int -> - Set (Vector Int) -> Set (Vector Int) -breadthFirstSearch hom v a = - S.fold f S.empty a - where - f x acc = - foldl (flip S.insert) acc - [ x // [(k, x!k + 1)] | - k <- indices x, -- When not hom, bound first element - hom || k > 0 || x!k == 0, -- of x to be no more than one - prod v x * v!k < 0 ] -- Fortenbacher contribution - --- Inner product -prod :: Vector Int -> Vector Int -> Int -prod x y = - sum [ x!i * y!i | i <- indices x ] - --- Remove unnecessary branches. A test vector is not necessary if all --- of its elements are greater than or equal to the elements of some --- minimal solution. -unnecessaryBranches :: Set (Vector Int) -> Set (Vector Int) -> Set (Vector Int) -unnecessaryBranches a m = - S.filter f a - where - f x = all (g x) (S.toList m) - g x y = not (lessEq y x) - --- Compare vectors element-wise. -lessEq :: Vector Int -> Vector Int -> Bool -lessEq x y = - all (\i-> x!i <= y!i) (indices x) diff --git a/src/CPSA/Lib/Algebra.hs b/src/CPSA/Lib/Algebra.hs --- a/src/CPSA/Lib/Algebra.hs +++ b/src/CPSA/Lib/Algebra.hs @@ -27,7 +27,7 @@ class (Ord t, Show t) => Term t where isVar :: t -> Bool -- Is term a variable in the algebra? - isMesgVar :: t -> Bool -- Is term a variable of sort mesg? + isAcquiredVar :: t -> Bool -- Is term an acquired variable? isAtom :: t -> Bool -- Is the sort of this term a base sort? -- Does a term occur in another term? @@ -160,8 +160,6 @@ -- Can environment be refined so it is the identity when applied -- to some terms? identityEnvFor :: (g, e) -> [t] -> [(g, e)] - -- specialize an environment by eliminating generated variables. - specialize :: e -> e -- Cast an environment into a substitution substitution :: e -> s -- Provide a concrete representation of an environment as an diff --git a/src/CPSA/Lib/Cohort.hs b/src/CPSA/Lib/Cohort.hs --- a/src/CPSA/Lib/Cohort.hs +++ b/src/CPSA/Lib/Cohort.hs @@ -18,7 +18,6 @@ {-- Debugging support import System.IO.Unsafe -import qualified CPSA.Lib.Utilities as U z :: Show a => a -> b -> b z x y = unsafePerformIO (print x >> return y) @@ -259,7 +258,8 @@ testNode mode k u ts derivable n t = loop cts where - loop [] = error ("Cohort.testNode missing test at " ++ show n) + loop [] = error ( + "Cohort.testNode missing test at " ++ show n ++ "\n" ++ show t) loop ((ct, eks) : cts) = case escapeSet ts derivable ct of Nothing -> loop cts diff --git a/src/CPSA/Lib/Expand.hs b/src/CPSA/Lib/Expand.hs --- a/src/CPSA/Lib/Expand.hs +++ b/src/CPSA/Lib/Expand.hs @@ -106,7 +106,7 @@ L pos xs -> -- Expand elements of list do xs <- mapM (expandAll macs) xs - return (L pos xs) + return (L pos (splice xs)) _ -> return sexpr -- Expand one S-expression limiting the number of expansions. @@ -145,3 +145,14 @@ subst env (L pos sexprs) = L pos (map (subst env) sexprs) subst _ sexpr = sexpr + +-- Splice sexprs that start with splice symbol. The splice symbol is ^. + +splice :: [SExpr Pos] -> [SExpr Pos] +splice [] = [] +splice ((L _ (S _ "^":xs)):ys) = + loop xs ys + where + loop [] ys = splice ys + loop (x:xs) ys = x:(loop xs ys) +splice (x:xs) = x:splice xs diff --git a/src/CPSA/Lib/Loader.hs b/src/CPSA/Lib/Loader.hs --- a/src/CPSA/Lib/Loader.hs +++ b/src/CPSA/Lib/Loader.hs @@ -179,7 +179,7 @@ $ originates t (rtrace role) origVarCheck v = failwith (showString "variable " $ showst v " not acquired") - $ not (isMesgVar v) || + $ not (isAcquiredVar v) || isJust (acquiredPos v (rtrace role)) failwith :: Monad m => String -> Bool -> m () diff --git a/src/CPSA/Lib/Main.hs b/src/CPSA/Lib/Main.hs --- a/src/CPSA/Lib/Main.hs +++ b/src/CPSA/Lib/Main.hs @@ -21,9 +21,15 @@ import CPSA.Lib.Reduction import qualified CPSA.Basic.Algebra import qualified CPSA.DiffieHellman.Algebra -import qualified CPSA.DiffieHellmanNoReciprocal.Algebra -import qualified CPSA.SimpleDiffieHellman.Algebra +-- Compile time switches for expermentation. + +-- Allow users to try experimental Diffie-Hellman algebra? +useDiffieHellman :: Bool +useDiffieHellman = False -- True + +-- Load default options + -- Default limit on the number of steps used to solve one problem. defaultStepLimit :: Int defaultStepLimit = optLimit defaultOptions @@ -86,11 +92,13 @@ -- Algebra specific section --- Algebra names +-- Algebra names -- omit Diffie-Hellman for releases until it works algs :: [String] -algs = [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name, - CPSA.DiffieHellmanNoReciprocal.Algebra.name, - CPSA.SimpleDiffieHellman.Algebra.name] +algs = + if useDiffieHellman then + [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name] + else + [CPSA.Basic.Algebra.name] -- Select the algebra and go. select :: [String] -> Maybe (SExpr Pos) -> Options -> [SExpr Pos] -> IO () @@ -101,12 +109,6 @@ files herald opts sexprs | name == CPSA.DiffieHellman.Algebra.name -> go name CPSA.DiffieHellman.Algebra.origin - files herald opts sexprs - | name == CPSA.DiffieHellmanNoReciprocal.Algebra.name -> - go name CPSA.DiffieHellmanNoReciprocal.Algebra.origin - files herald opts sexprs - | name == CPSA.SimpleDiffieHellman.Algebra.name -> - go name CPSA.SimpleDiffieHellman.Algebra.origin files herald opts sexprs | otherwise -> abort ("Bad algebra: " ++ name) diff --git a/src/CPSA/Lib/Strand.hs b/src/CPSA/Lib/Strand.hs --- a/src/CPSA/Lib/Strand.hs +++ b/src/CPSA/Lib/Strand.hs @@ -29,6 +29,9 @@ {-- import System.IO.Unsafe +import Control.Exception (try) +import System.IO.Error (ioeGetErrorString) + z :: Show a => a -> b -> b z x y = unsafePerformIO (print x >> return y) @@ -65,6 +68,16 @@ displayTerm (context range) t) context ts = addToContext emptyContext ts +zv :: Algebra t p g s e c => Preskel t g s e -> String +zv k = + unsafePerformIO $ do + y <- try $ verbosePreskelWellFormed k + case y of + Right _ -> + return "preskel well formed" + Left err -> + return $ ioeGetErrorString err + -- Also see showst --} @@ -179,7 +192,7 @@ Trace t -> Instance t e makeInstance role env trace = Instance { role = role, - env = specialize env, + env = env, trace = trace, height = length trace } diff --git a/src/CPSA/Logic/Main.hs b/src/CPSA/Logic/Main.hs --- a/src/CPSA/Logic/Main.hs +++ b/src/CPSA/Logic/Main.hs @@ -14,14 +14,10 @@ import CPSA.Logic.Logic import qualified CPSA.Basic.Algebra import qualified CPSA.DiffieHellman.Algebra -import qualified CPSA.DiffieHellmanNoReciprocal.Algebra -import qualified CPSA.SimpleDiffieHellman.Algebra -- Algebra names algs :: [String] -algs = [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name, - CPSA.DiffieHellmanNoReciprocal.Algebra.name, - CPSA.SimpleDiffieHellman.Algebra.name] +algs = [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name] main :: IO () main = @@ -38,13 +34,6 @@ p ([], []) | alg == CPSA.DiffieHellman.Algebra.name -> go (step h alg CPSA.DiffieHellman.Algebra.origin margin) - p ([], []) - | alg == CPSA.DiffieHellmanNoReciprocal.Algebra.name -> - go (step h alg - CPSA.DiffieHellmanNoReciprocal.Algebra.origin margin) - p ([], []) - | alg == CPSA.SimpleDiffieHellman.Algebra.name -> - go (step h alg CPSA.SimpleDiffieHellman.Algebra.origin margin) p ([], []) | otherwise -> abort ("Bad algebra: " ++ alg) diff --git a/src/CPSA/Parameters/Main.hs b/src/CPSA/Parameters/Main.hs --- a/src/CPSA/Parameters/Main.hs +++ b/src/CPSA/Parameters/Main.hs @@ -17,14 +17,10 @@ import CPSA.Parameters.Flow import qualified CPSA.Basic.Algebra import qualified CPSA.DiffieHellman.Algebra -import qualified CPSA.DiffieHellmanNoReciprocal.Algebra -import qualified CPSA.SimpleDiffieHellman.Algebra -- Algebra names algs :: [String] -algs = [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name, - CPSA.DiffieHellmanNoReciprocal.Algebra.name, - CPSA.SimpleDiffieHellman.Algebra.name] +algs = [CPSA.Basic.Algebra.name, CPSA.DiffieHellman.Algebra.name] main :: IO () main = @@ -40,11 +36,6 @@ go (step h alg CPSA.Basic.Algebra.origin margin) p | alg == CPSA.DiffieHellman.Algebra.name -> go (step h alg CPSA.DiffieHellman.Algebra.origin margin) p - | alg == CPSA.DiffieHellmanNoReciprocal.Algebra.name -> - go (step h alg - CPSA.DiffieHellmanNoReciprocal.Algebra.origin margin) p - | alg == CPSA.SimpleDiffieHellman.Algebra.name -> - go (step h alg CPSA.SimpleDiffieHellman.Algebra.origin margin) p | otherwise -> abort ("Bad algebra: " ++ alg) hClose h diff --git a/src/CPSA/SimpleDiffieHellman/Algebra.hs b/src/CPSA/SimpleDiffieHellman/Algebra.hs deleted file mode 100644 --- a/src/CPSA/SimpleDiffieHellman/Algebra.hs +++ /dev/null @@ -1,1348 +0,0 @@ --- Simple Diffie-Hellman Algebra implementation - --- This module implements a simple version of Diffie-Hellman in which --- only commutativity of exponents is support via the equation --- --- (exp (exp x y) z) = (exp (exp x y) z) --- --- The module implements a many-sorted algebra, but is used as an --- order-sorted algebra. It exports a name, and the origin used to --- generate variables. - --- Copyright (c) 2009 The MITRE Corporation --- --- This program is free software: you can redistribute it and/or --- modify it under the terms of the BSD License as published by the --- University of California. - -{-# LANGUAGE MultiParamTypeClasses #-} - -module CPSA.SimpleDiffieHellman.Algebra (name, origin) where - -import Control.Monad (foldM) -import qualified Data.List as L -import qualified Data.Set as S -import Data.Set (Set) -import qualified Data.Map as M -import Data.Map (Map) -import Data.Char (isDigit) -import qualified CPSA.Lib.CPSA as C -import CPSA.Lib.CPSA (SExpr(..), Pos, annotation) - -name :: String -name = "diffie-hellman" - --- An identifier is a variable without any information about its sort - -newtype Id = Id (Integer, String) deriving Show - --- The integer distinguishes an identifier, the string is for printing. - -instance Eq Id where - (Id (x, _)) == (Id (x', _)) = x == x' - -instance Ord Id where - compare (Id (x, _)) (Id (x', _)) = compare x x' - -idName :: Id -> String -idName (Id (_, name)) = name - --- Counter used for generating fresh identifiers. - -newtype Gen = Gen (Integer) deriving Show - -origin :: Gen -origin = Gen (0) - -freshId :: Gen -> String -> (Gen, Id) -freshId (Gen (i)) name = (Gen (i + 1), Id (i, name)) - -cloneId :: Gen -> Id -> (Gen, Id) -cloneId gen x = freshId gen (idName x) - --- The Simple Diffie-Hellman Order-Sorted Signature is - --- Sorts: mesg, text, data, name, skey, akey, string, base, and expn --- --- Subsorts: text, data, name, skey, akey, base, expn < mesg --- --- Note that both mesg and base are not base sorts. --- --- Operations: --- cat : mesg X mesg -> mesg Pairing --- enc : mesg X mesg -> mesg Encryption --- hash : mesg X mesg -> mesg Hashing --- string : mesg Tag constants --- ltk : name X name -> skey Long term shared key --- pubk : name -> akey Public key of principal --- pubk : string X name -> akey Tagged public key of principal --- invk : akey -> akey Inverse of asymmetric key --- gen : base Generator --- exp : base -> expn -> base Exponentiation - --- Variables of sort string are forbidden. - --- The implementation exploits the isomorphism between order-sorted --- algebras and many-sorted algebras by adding inclusion operations to --- produce an equivalent Simple Diffie-Hellman Many-Sorted Signature. --- There is an inclusion operation for each subsort of mesg. - --- Sorts: mesg, text, data, name, skey, akey, and string --- --- Operations: --- cat : mesg X mesg -> mesg Pairing --- enc : mesg X mesg -> mesg Encryption --- hash : mesg -> mesg Hashing --- string : mesg Tag constants --- ltk : name X name -> skey Long term shared key --- pubk : name -> akey Public key of principal --- pubk : string X name -> akey Tagged public key of principal --- gen : base Generator --- exp : base X expn -> base Exponentiation --- invk : akey -> akey Inverse of asymmetric key --- text : text -> mesg Sort text inclusion --- data : data -> mesg Sort date inclusion --- name : name -> mesg Sort name inclusion --- skey : skey -> mesg Sort skey inclusion --- akey : akey -> mesg Sort akey inclusion --- base : base -> mesg Sort akey inclusion --- expn : expn -> mesg Sort akey inclusion - --- In both algebras, invk(invk(t)) = t for all t of sort akey and --- exp(exp(x, y), z) = exp(exp(x, z), y) for all x, y of sort --- expn and x of sort base. - --- Operations other than the tag constant constructor -data Symbol - = Text -- Text - | Data -- Another text-like item - | Name -- Principal - | Skey -- Symmetric key - | Base -- Base of an exponentiated atom - | Expn -- Exponent - | Ltk -- Long term shared symmetric key - | Akey -- Asymmetric key - | Invk -- Inverse of asymmetric key - | Pubk -- Public asymmetric key of a principal - | Genr -- The generator constant for the group - | Exp -- Exponentiation function symbol - | Cat -- Term concatenation (Pairing really) - | Enc -- Encryption - | Hash -- Hashing - deriving (Show, Eq, Ord, Enum, Bounded) - --- A Basic Crypto Algebra Term - -data Term - = I !Id - | C !String -- Tag constants - | F !Symbol ![Term] - deriving Show - --- In this algebra (F Invk [F Invk [t]]) == t is an axiom --- and (F Exp [F Exp [x, y], z]) == (F Exp [F Exp [x, z], y]) - -equalTerm :: Term -> Term -> Bool -equalTerm (I x) (I y) = x == y -equalTerm (C c) (C c') = c == c' -equalTerm (F Invk [F Invk [t]]) t' = equalTerm t t' -equalTerm t (F Invk [F Invk [t']]) = equalTerm t t' -equalTerm (F Exp [x, y]) (F Exp [x', y']) = - case (normalize x y, normalize x' y') of - ((x, y), (x', y')) -> equalTerm x x' && equalTerm y y' -equalTerm (F s u) (F s' u') = - s == s' && u == u' -equalTerm _ _ = False - -normalize :: Term -> Term -> (Term, Term) -normalize (F Exp [x, y]) (I z) = - case normalize x y of - (x, I y) | z < y -> normalize (F Exp [x, I z]) (I y) - (x, y) -> (F Exp [x, y], I z) -normalize x y = (x, y) - -instance Eq Term where - (==) = equalTerm - --- Term comparison respecting the axiom - -compareTerm :: Term -> Term -> Ordering -compareTerm (I x) (I y) = compare x y -compareTerm (C c) (C c') = compare c c' -compareTerm (F Invk [F Invk [t]]) t' = compareTerm t t' -compareTerm t (F Invk [F Invk [t']]) = compareTerm t t' -compareTerm (F Exp [x, y]) (F Exp [x', y']) = - compare (normalize x y) (normalize x' y') -compareTerm (F s u) (F s' u') = - case compare s s' of - EQ -> compare u u' - o -> o -compareTerm (I _) (C _) = LT -compareTerm (C _) (I _) = GT -compareTerm (I _) (F _ _) = LT -compareTerm (F _ _) (I _) = GT -compareTerm (C _) (F _ _) = LT -compareTerm (F _ _) (C _) = GT - -instance Ord Term where - compare = compareTerm - --- Basic terms are introduced by defining a function used to decide if --- a term is well-formed. The context of an occurrence of an identifier --- determines its sort. A term that contains just an identifier and its --- sort information is called a variable. The sort of a variable is --- one of mesg, text, data, name, skey, akey, base, and expn. - --- Terms that represent variables. -isVar :: Term -> Bool -isVar (I _) = True -- Sort: mesg -isVar (F s [I _]) = - -- Sorts: text, data, name, skey, akey, base, and expn - s == Text || s == Data || s == Name || s == Skey || s == Akey || - s == Base || s == Expn -isVar _ = False - --- Extract the identifier from a variable -varId :: Term -> Id -varId (I x) = x -varId (F Text [I x]) = x -varId (F Data [I x]) = x -varId (F Name [I x]) = x -varId (F Skey [I x]) = x -varId (F Akey [I x]) = x -varId (F Base [I x]) = x -varId (F Expn [I x]) = x -varId _ = error "Algebra.varId: term not a variable with its sort" - -isMesgVar :: Term -> Bool -isMesgVar (I _) = True -isMesgVar _ = False - --- A list of terms are well-formed if each one has the correct --- structure and every occurrence of an identifier in a term has the --- same sort. Variable environments are used to check the sort --- condition. It maps an identifier to a variable that contains the --- identifier. - --- termsWellFormed u ensures all terms in u use each identifier at the --- same sort, and makes sure every term has the correct structure. -termsWellFormed :: [Term] -> Bool -termsWellFormed u = - loop emptyVarEnv u - where - loop _ [] = True - loop env (t : u) = - case termWellFormed env t of - Nothing -> False - Just env' -> loop env' u - -newtype VarEnv = VarEnv (Map Id Term) deriving Show - -emptyVarEnv :: VarEnv -emptyVarEnv = VarEnv M.empty - --- A term is well-formed if it is in the language defined by the --- following grammar, and variables occur at positions within the term --- in a way that allows each variable to be assigned one sort. --- --- The start symbol is T, for all well-formed terms. Terminal symbol --- I is for variables and terminal symbol C is for quoted strings. --- The non-terminal symbols are B, K, E, and T. Symbol B is for base --- sorted terms, K is for asymmetric keys, E is for the base of an --- exponent. --- --- T ::= I | C | B | cat(T, T) | enc(T, T) | hash(T) --- --- B ::= text(I) | data(I) | name(I) | skey(I) --- | skey(I) | skey(ltk(I, I)) | akey(K) | base(E) | expn(I) --- --- K ::= I | pubk(I) | invk(I) | invk(pubk(I)) --- --- E ::= I | genr | exp(E, I) - --- termWellFormed checks the structure and sort condition. -termWellFormed :: VarEnv -> Term -> Maybe VarEnv -termWellFormed xts t@(I x) = - extendVarEnv xts x t -- Mesg variable -termWellFormed xts t@(F Text [I x]) = - extendVarEnv xts x t -- Text variable -termWellFormed xts t@(F Data [I x]) = - extendVarEnv xts x t -- Data variable -termWellFormed xts t@(F Name [I x]) = - extendVarEnv xts x t -- Name variable -termWellFormed xts t@(F Skey [I x]) = - extendVarEnv xts x t -- Symmetric key variable -termWellFormed xts (F Skey [F Ltk [I x, I y]]) = - -- Long term shared symmetric key - doubleTermWellFormed xts (F Name [I x]) (F Name [I y]) -termWellFormed xts (F Akey [t]) = -- Asymmetric key terms - case t of - I x -> extendVarEnv xts x (F Akey [I x]) - F Invk [I x] -> extendVarEnv xts x (F Akey [I x]) - F Pubk [I x] -> extendVarEnv xts x (F Name [I x]) - F Pubk [C _, I x] -> extendVarEnv xts x (F Name [I x]) - F Invk [F Pubk [I x]] -> extendVarEnv xts x (F Name [I x]) - F Invk [F Pubk [C _, I x]] -> extendVarEnv xts x (F Name [I x]) - _ -> Nothing -termWellFormed xts (F Base [t]) = -- Base terms - case t of - I x -> extendVarEnv xts x (F Base [I x]) - F Genr [] -> Just xts - F Exp [x, I y] -> - do - xts' <- extendVarEnv xts y (F Expn [I y]) - termWellFormed xts' (F Base [x]) - _ -> Nothing -termWellFormed xts t@(F Expn [I x]) = - extendVarEnv xts x t -- Exponent variable -termWellFormed xts (C _) = - Just xts -- Tags -termWellFormed xts (F Cat [t0, t1]) = - doubleTermWellFormed xts t0 t1 -- Concatenation -termWellFormed xts (F Enc [t0, t1]) = - doubleTermWellFormed xts t0 t1 -- Encryption -termWellFormed xts (F Hash [t]) = - termWellFormed xts t -- Hashing -termWellFormed _ _ = Nothing - --- Extend when sorts agree -extendVarEnv :: VarEnv -> Id -> Term -> Maybe VarEnv -extendVarEnv (VarEnv env) x t = - case M.lookup x env of - Nothing -> Just $ VarEnv $ M.insert x t env - Just t' -> if t == t' then Just (VarEnv env) else Nothing - -doubleTermWellFormed :: VarEnv -> Term -> Term -> Maybe VarEnv -doubleTermWellFormed xts t0 t1 = - do - xts <- termWellFormed xts t0 - termWellFormed xts t1 - --- Is the sort of the term a base sort? -isAtom :: Term -> Bool -isAtom (I _) = False -isAtom (C _) = False -isAtom (F s _) = -- Note Base is not a base sort! - s == Text || s == Data || s == Name || - s == Skey || s == Akey || s == Expn - --- Does a term occur in another term? -occursIn :: Term -> Term -> Bool -occursIn t t' = - t == t' || - case t' of - F _ u -> any (occursIn t) u - _ -> False - --- Fold f through a term applying it to each variable in the term. -foldVars :: (a -> Term -> a) -> a -> Term -> a -foldVars f acc t@(I _) = f acc t -- Mesg variable -foldVars f acc t@(F Text [I _]) = f acc t -- Text variable -foldVars f acc t@(F Data [I _]) = f acc t -- Data variable -foldVars f acc t@(F Name [I _]) = f acc t -- Name variable -foldVars f acc t@(F Skey [I _]) = f acc t -- Symmetric keys -foldVars f acc (F Skey [F Ltk [I x, I y]]) = - f (f acc (F Name [I x])) (F Name [I y]) -foldVars f acc t@(F Akey [I _]) = f acc t -- Asymmetric keys -foldVars f acc (F Akey [F Invk [I x]]) = f acc (F Akey [I x]) -foldVars f acc (F Akey [F Pubk [I x]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Pubk [C _, I x]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Invk [F Pubk [I x]]]) = f acc (F Name [I x]) -foldVars f acc (F Akey [F Invk [F Pubk [C _, I x]]]) = f acc (F Name [I x]) -foldVars f acc t@(F Expn [I _]) = f acc t -- Exponent variable -foldVars f acc t@(F Base [I _]) = f acc t -- Base variable -foldVars _ acc (F Base [F Genr []]) = acc -foldVars f acc (F Base [F Exp [t0, t1]]) = - foldVars f (f acc (F Expn [t1])) (F Base [t0]) -foldVars _ acc (C _) = acc -- Tags -foldVars f acc (F Cat [t0, t1]) = -- Concatenation - foldVars f (foldVars f acc t0) t1 -foldVars f acc (F Enc [t0, t1]) = -- Encryption - foldVars f (foldVars f acc t0) t1 -foldVars f acc (F Hash [t]) = -- Hashing - foldVars f acc t -foldVars _ _ t = error $ "Algebra.foldVars: Bad term " ++ show t - --- Fold f through a term applying it to each term that is carried by the --- term. --- --- Semantics change: this used to fold f through a term applying it to --- each term that is carried by the term. -foldCarriedTerms :: (a -> Term -> a) -> a -> Term -> a -foldCarriedTerms f acc t@(F Cat [t0, t1]) = -- Concatenation - foldCarriedTerms f (foldCarriedTerms f (f acc t) t0) t1 -foldCarriedTerms f acc t@(F Enc [t0, _]) = -- Encryption - foldCarriedTerms f (f acc t) t0 -foldCarriedTerms f acc t@(F Base [F Exp [_, _]]) = -- Exponent - foldExpnTerms f (f acc t) t - where - foldExpnTerms f acc (F Base [F Exp [t0, t1]]) = - foldExpnTerms f (f acc (F Expn [t1])) (F Base [t0]) - foldExpnTerms _ acc _ = acc -foldCarriedTerms f acc t = f acc t -- atoms and tags - --- Is a term carried by another term? -carriedBy :: Term -> Term -> Bool -carriedBy t t' = - t == t' || - case t' of - F Cat [t0, t1] -> carriedBy t t0 || carriedBy t t1 - F Enc [t0, _] -> carriedBy t t0 - _ -> False - --- The key used to decrypt an encrypted term, otherwise Nothing. -decryptionKey :: Term -> Maybe Term -decryptionKey (F Enc [_, t]) = Just (inv t) -decryptionKey _ = Nothing - -buildable :: Set Term -> Set Term -> Term -> Bool -buildable knowns unguessable term = - ba term - where - ba (I _) = True -- A mesg sorted variable is always buildable - ba (C _) = True -- So is a tag - ba (F Cat [t0, t1]) = - ba t0 && ba t1 - ba t@(F Hash [t1]) = - S.member t knowns || ba t1 - ba t@(F Enc [t0, t1]) = - S.member t knowns || ba t0 && ba t1 - ba t@(F Base [t0]) = - S.member t knowns || bb t0 - ba t = isAtom t && not (S.member t unguessable) - - bb (I _) = True -- A base sorted variable is always buildable - bb (F Genr []) = True -- So is the generator - bb (F Exp [F Exp [t0, t1], t2]) = -- Use equation - ba (F Base [F Exp [t0, t1]]) && ba (F Expn [t2]) || - ba (F Base [F Exp [t0, t2]]) && ba (F Expn [t1]) - bb (F Exp [t0, t1]) = ba (F Base [t0]) && ba (F Expn [t1]) - bb _ = False - --- Compute the decomposition given some known terms and some unguessable --- atoms. The code is quite tricky. It iterates until the known --- terms don't change. The known terms ends up with all the --- encryptions that are known. -decompose :: Set Term -> Set Term -> (Set Term, Set Term) -decompose knowns unguessable = - loop unguessable knowns S.empty [] - where - loop unguessable knowns old [] - | old == knowns = (knowns, unguessable) -- Done - | otherwise = loop unguessable knowns knowns (S.elems knowns) - loop unguessable knowns old (t@(F Cat _) : todo) = - loop unguessable (decat t (S.delete t knowns)) old todo - loop unguessable knowns old ((F Enc [t0, t1]) : todo) - | buildable knowns unguessable (inv t1) = -- Add plaintext - loop unguessable (decat t0 knowns) old todo - | otherwise = loop unguessable knowns old todo - loop unguessable knowns old ((F Hash [_]) : todo) = - loop unguessable knowns old todo -- Hash can't be decomposed - loop unguessable knowns old ((F Base [F Exp [_, _]]) : todo) = - loop unguessable knowns old todo - loop unguessable knowns old (t : todo) = - loop (S.delete t unguessable) (S.delete t knowns) old todo - -- Decat - decat (F Cat [t0, t1]) s = decat t1 (decat t0 s) - decat t s = S.insert t s - --- Inverts an asymmetric key -inv :: Term -> Term -inv (F Akey [F Invk [t]]) = F Akey [t] -inv (F Akey [t]) = F Akey [F Invk [t]] -inv (I _) = error "Algebra.inv: Cannot invert a variable of sort mesg" -inv t = t - --- Extracts every encryption that is carried by a term along with its --- encryption key. Note that a hash is treated as a kind of --- encryption in which the term that is hashed is the encryption key. --- (This needs more work.) -encryptions :: Term -> [(Term, [Term])] -encryptions t = - reverse $ loop t [] - where - loop (F Cat [t, t']) acc = - loop t' (loop t acc) - loop t@(F Enc [t', t'']) acc = - loop t' (adjoin (t, [t'']) acc) - loop t@(F Hash [t']) acc = - adjoin (t, [t']) acc - loop t@(F Base [F Exp [F Exp [_, t'], t'']]) acc = - adjoin (t, [F Expn [t'], F Expn [t'']]) acc - loop t@(F Base [F Exp [t', t'']]) acc = - loop (F Base [t']) (adjoin (t, [F Expn [t'']]) acc) - loop _ acc = acc - adjoin x xs - | x `elem` xs = xs - | otherwise = x : xs - --- Returns the encryptions that carry the target. If the target is --- carried outside all encryptions, or is exposed because a decription --- key is derivable, Nothing is returned. -protectors :: (Term -> Bool) -> Term -> Term -> Maybe [Term] -protectors derivable target source = - do - ts <- bare source S.empty - return $ S.elems ts - where - bare source _ - | source == target = Nothing - bare (F Cat [t, t']) acc = - maybe Nothing (bare t') (bare t acc) - bare t@(F Enc [t', key]) acc = - if target `carriedBy` t' then - if derivable (inv key) then - bare t' acc - else - Just (S.insert t acc) - else - Just acc - -- A base value is protector if the target is one of its exponents - bare t@(F Base [_]) acc - | target `carriedBy` t = Just (S.insert t acc) - | otherwise = Just acc - bare _ acc = Just acc - --- This section is busted and needs attention - --- Support for data flow analysis of traces. A flow rule maps an --- initial set of atoms and a set of available terms to sets of pairs --- of the same sets. -type FlowRule = (Set Term, Set Term) -> Set (Set Term, Set Term) - --- Combine flow rules sequentially. -comb :: FlowRule -> FlowRule -> FlowRule -comb f g x = - S.fold h S.empty (g x) - where - h a s = S.union (f a) s - --- Analyze a term as a sent term. -outFlow :: Term -> FlowRule -outFlow t a@(_, available) - | S.member t available = S.singleton a -outFlow (I _) _ = S.empty -outFlow (C _) a = S.singleton a -outFlow (F Base [F Genr []]) a = S.singleton a -outFlow (F Cat [t0, t1]) a = -- Construct non-atoms - comb (outFlow t1) (outFlow t0) a -outFlow (F Enc [t0, t1]) a = - comb (outFlow t1) (outFlow t0) a -outFlow (F Hash [t]) a = - outFlow t a -outFlow (F Base [F Exp [t0, t1]]) a = - comb (outFlow (F Base [t0])) (outFlow (F Expn [t1])) a -outFlow t (initial, available) = -- Don't look inside atoms - S.singleton (S.insert t initial, S.insert t available) - --- Analyze a term as a received term. -inFlow :: Term -> FlowRule -inFlow (C _) a = S.singleton a -inFlow (F Base [F Genr []]) a = S.singleton a -inFlow (F Cat [t0, t1]) a = -- Try to receive components - S.union -- in both orders - (comb (inFlow t1) (inFlow t0) a) - (comb (inFlow t0) (inFlow t1) a) -inFlow t@(F Enc [t0, t1]) (initial, available) = - S.union - (outFlow t (initial, available)) -- Encryption can be built - (comb (inFlow t0) (outFlow (inv t1)) a) -- or decrypted - where -- Derive decryption key first - a = (initial, S.insert t available) -inFlow t@(F Base [F Exp [_, _]]) a = - outFlow t a -- Can be built -inFlow (F Hash [t0]) (initial, available) = - outFlow t0 (initial, available) -inFlow t (initial, available) = - S.singleton (initial, S.insert t available) - -instance C.Term Term where - isVar = isVar - isMesgVar = isMesgVar - isAtom = isAtom - termsWellFormed = termsWellFormed - occursIn = occursIn - foldVars = foldVars - foldCarriedTerms = foldCarriedTerms - carriedBy = carriedBy - decryptionKey = decryptionKey - decompose = decompose - buildable = buildable - encryptions = encryptions - protectors = protectors - outFlow = outFlow - inFlow = inFlow - loadTerm = loadTerm - --- Places - --- A place names a one subterm within a term. It is a list of --- integers giving a path through a term to that named subterm. Each --- integer in the list identifies the subterm in a function --- application on the path to the named subterm. The integer is the --- index of the subterm in the application's list of terms. - -newtype Place = Place [Int] deriving Show - --- Returns the places a variable occurs within another term. -places :: Term -> Term -> [Place] -places target source = - f [] [] source - where - f paths path source - | I (varId target) == source = Place (reverse path) : paths - f paths path (F _ u) = - g paths path 0 u - f paths _ _ = paths - g paths _ _ [] = paths - g paths path i (t : u) = - g (f paths (i: path) t) path (i + 1) u - --- Replace a variable within a term at a given place. -replace :: Term -> Place -> Term -> Term -replace target (Place ints) source = - loop ints source - where - loop [] _ = I (varId target) - loop (i : path) (F s u) = - F s (C.replaceNth (loop path (u !! i)) i u) - loop _ _ = error "Algebra.replace: Bad path to variable" - --- Returns the places a term is carried by another term. --- --- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! --- Semantics change: this used to return the places a term is carried --- by another term. -carriedPlaces :: Term -> Term -> [Place] -carriedPlaces target source = - f [] [] source - where - f paths path source - | target == source = Place (reverse path) : paths - f paths path (F Cat [t, t']) = - f (f paths (0 : path) t) (1 : path) t' - f paths path (F Enc [t, _]) = - f paths (0 : path) t - f paths path (F Base [t]) = - exp paths (0 : path) t - where - exp paths path (F Exp [t, t']) = - exp (f paths (1 : path) (F Expn [t'])) (0 : path) t - exp paths _ _ = paths - f paths _ _ = paths - --- Return the ancestors of the term at the given place. -ancestors :: Term -> Place -> [Term] -ancestors source (Place ints) = - loop [] ints source - where - loop ts [] _ = ts - loop ts (i: path) t@(F _ u) = - loop (t : ts) path (u !! i) - loop _ _ _ = error "Algebra.ancestors: Bad path to term" - -instance C.Place Term Place where - places = places - carriedPlaces = carriedPlaces - replace = replace - ancestors = ancestors - --- Rename the identifiers in a term. Gen keeps the state of the --- renamer. (Question: should alist be replaced by a Map?) -clone :: Gen -> Term -> (Gen, Term) -clone gen t = - (gen', t') - where - (_, gen', t') = cloneTerm ([], gen) t - cloneTerm (alist, gen) t = - case t of -- The association list maps - I x -> -- identifiers to identifier. - case lookup x alist of - Just y -> (alist, gen, I y) - Nothing -> - let (gen', y) = cloneId gen x in - ((x, y) : alist, gen', I y) - C c -> (alist, gen, C c) - F sym u -> - let (alist', gen', u') = - foldl cloneTermList (alist, gen, []) u in - (alist', gen', F sym $ reverse u') - cloneTermList (alist, gen, u) t = - let (alist', gen', t') = cloneTerm (alist, gen) t in - (alist', gen', t' : u) - -instance C.Gen Term Gen where - origin = origin - clone = clone - loadVars = loadVars - --- Functions used in both unification and matching - -type IdMap = Map Id Term - -emptyIdMap :: IdMap -emptyIdMap = M.empty - --- Apply a substitution to a term -idSubst :: IdMap -> Term -> Term -idSubst subst (I x) = - M.findWithDefault (I x) x subst -idSubst _ t@(C _) = t -idSubst subst (F Invk [t]) = - case idSubst subst t of - F Invk [t] -> t -- Apply axiom - t -> F Invk [t] -idSubst subst (F Exp [x, y]) = - F Exp [x', y'] - where -- Apply other axiom - (x', y') = normalize (idSubst subst x) (idSubst subst y) -idSubst subst (F s u) = - F s (map (idSubst subst) u) - --- Unification and substitution - -newtype Subst = Subst IdMap deriving (Eq, Ord, Show) - -emptySubst :: Subst -emptySubst = Subst emptyIdMap - --- Apply a substitution created by unification -substitute :: Subst -> Term -> Term -substitute (Subst s) t = - idSubst s t - --- Composition of substitutions - --- substitute (compose s0 s1) t = substitute s0 (substitute s1 t) - --- 1. apply s0 to range of s1 to obtain s2; --- 2. remove bindings is s0 where domains of s0 and s1 overlap to form s3; --- 3. remove trivial bindings from s2 to form s4; and --- 4. take the union of s4 and s3. - -compose :: Subst -> Subst -> Subst -compose (Subst s0) (Subst s1) = - let s2 = M.map (substitute (Subst s0)) s1 -- Step 1 - s4 = M.filterWithKey nonTrivialBinding s2 in -- Step 3 - Subst (M.union s4 s0) -- Steps 2 and 4, union is left-biased - -nonTrivialBinding :: Id -> Term -> Bool -nonTrivialBinding x (I y) = x /= y -nonTrivialBinding _ _ = True - --- During unification, variables determined to be equal are collected --- into an equivalence class. Multiple lookups of each variable in --- the internal representation of a substitution finds the canonical --- representive of the class. The chase function finds the current --- canonical representitive. - --- Get the canonical representative of equivalent identifiers making use --- of this algebra's axiom. -chase :: Subst -> Term -> Term -chase (Subst s) (I x) = - case M.lookup x s of - Nothing -> I x - Just t -> chase (Subst s) t -chase s (F Invk [t]) = chaseInvk s t -chase _ t = t - -chaseInvk :: Subst -> Term -> Term -chaseInvk (Subst s) (I x) = - case M.lookup x s of - Nothing -> F Invk [I x] - Just t -> chaseInvk (Subst s) t -chaseInvk s (F Invk [t]) = chase s t -chaseInvk _ t = F Invk [t] - --- Does x occur in t? -occurs :: Id -> Term -> Bool -occurs x (I y) = x == y -occurs _ (C _) = False -occurs x (F _ u) = any (occurs x) u - -type GenSubst = (Gen, Subst) - -unifyChase :: Term -> Term -> GenSubst -> [GenSubst] -unifyChase t t' (g, s) = unifyTerms (chase s t) (chase s t') (g, s) - --- To make unification tractable, one makes use of the equation --- (exp (exp (gen) x) y) = (exp (exp (gen) y) x). -unifyTerms :: Term -> Term -> GenSubst -> [GenSubst] -unifyTerms (I x) (I y) (g, Subst s) = - case compare x y of - EQ -> [(g, Subst s)] - GT -> [(g, Subst $ M.insert x (I y) s)] - LT -> [(g, Subst $ M.insert y (I x) s)] -unifyTerms (I x) t (g, Subst s) - | occurs x t = [] - | otherwise = [(g, Subst $ M.insert x t s)] -unifyTerms t (I x) s = unifyTerms (I x) t s -unifyTerms (C c) (C c') s - | c == c' = [s] - | otherwise = [] -unifyTerms (F Invk [I x]) (F Pubk [I y]) s = - unifyTerms (I x) (F Invk [F Pubk [I y]]) s -unifyTerms (F Invk [I x]) (F Pubk [C c, I y]) s = - unifyTerms (I x) (F Invk [F Pubk [C c, I y]]) s -unifyTerms (F Pubk [I x]) (F Invk [I y]) s = - unifyTerms (I y) (F Invk [F Pubk [I x]]) s -unifyTerms (F Pubk [C c, I x]) (F Invk [I y]) s = - unifyTerms (I y) (F Invk [F Pubk [C c, I x]]) s -{-- -unifyTerms (F Exp [F Exp [F Genr [], x], y]) (F Exp [F Exp [u, v], w]) (g, s) = - unifyTermLists [F Genr [], x, y] [u, v, w] (g, s) ++ - unifyTermLists [F Genr [], x, y] [u, w, v] (g, s) -unifyTerms (F Exp [F Exp [u, v], w]) (F Exp [F Exp [F Genr [], x], y]) (g, s) = - unifyTermLists [F Genr [], x, y] [u, v, w] (g, s) ++ - unifyTermLists [F Genr [], x, y] [u, w, v] (g, s) --} -unifyTerms (F Exp [x, y]) (F Exp [u, v]) (g, s) = - unifyTermLists [x, y] [u, v] (g, s) ++ - do - gs <- unifyTermLists [x, y] left (g'', s) - unifyTermLists right [u, v] gs - where - (g', ix) = freshId g "x" - (g'', iy) = freshId g' "y" - left = [F Exp [F Genr [], I ix], I iy] - right = [F Exp [F Genr [], I iy], I ix] -unifyTerms (F sym u) (F sym' u') s - | sym == sym' = unifyTermLists u u' s - | otherwise = [] -unifyTerms _ _ _ = [] - -unifyTermLists :: [Term] -> [Term] -> GenSubst -> [GenSubst] -unifyTermLists [] [] s = [s] -unifyTermLists (t : u) (t' : u') s = - do - s' <- unifyChase t t' s - unifyTermLists u u' s' -unifyTermLists _ _ _ = [] - --- The exported unifier converts the internal representation of a --- substitution into the external form using chaseMap. - -unify :: Term -> Term -> GenSubst -> [GenSubst] -unify t t' s = - do - (g, s) <- unifyChase t t' s - return $ (g, chaseMap s) - --- Apply the chasing version of substitution to the range of s. - -chaseMap :: Subst -> Subst -chaseMap (Subst s) = - Subst $ M.map (substChase (Subst s)) s - --- A chasing version of substitution. - -substChase :: Subst -> Term -> Term -substChase subst t = - case chase subst t of - t@(I _) -> t - t@(C _) -> t - F Invk [t] -> - case substChase subst t of - F Invk [t] -> t -- Apply axiom - t -> F Invk [t] - F Exp [x, y] -> - F Exp [x', y'] - where -- Apply other axiom - (x', y') = normalize (substChase subst x) (substChase subst y) - F s u -> - F s (map (substChase subst) u) - -instance C.Subst Term Gen Subst where - emptySubst = emptySubst - substitute = substitute - unify = unify - compose = compose - --- Matching and instantiation - -newtype Env = Env IdMap deriving (Eq, Ord, Show) - --- An environment may contain an explicit identity mapping, whereas a --- substitution is erroneous if it has one. - -emptyEnv :: Env -emptyEnv = Env emptyIdMap - --- Apply a substitution created my matching -instantiate :: Env -> Term -> Term -instantiate (Env r) t = idSubst r t - --- Matching - -type GenEnv = (Gen, Env) - --- The matcher has the property that when pattern P and term T match --- then instantiate (match P T emptyEnv) P = T. -match :: Term -> Term -> GenEnv -> [GenEnv] -match (I x) t (g, Env r) = - case M.lookup x r of - Nothing -> [(g, Env $ M.insert x t r)] - Just t' -> if t == t' then [(g, Env r)] else [] -match (C c) (C c') r = if c == c' then [r] else [] -match (F Exp [x, y]) (F Exp [F Exp [u, v], w]) r = - matchLists [x, y] [F Exp [u, v], w] r ++ - matchLists [x, y] [F Exp [u, w], v] r -match (F s u) (F s' u') r - | s == s' = matchLists u u' r -match (F Invk [t]) t' r = - match t (F Invk [t']) r -match _ _ _ = [] - -matchLists :: [Term] -> [Term] -> GenEnv -> [GenEnv] -matchLists [] [] r = [r] -matchLists (t : u) (t' : u') r = - do - r <- match t t' r - matchLists u u' r -matchLists _ _ _ = [] - --- Does every varible in ts not occur in the domain of e? --- Trivial bindings in e are ignored. -identityEnvFor :: Env -> [Term] -> Bool -identityEnvFor (Env r) ts = - all (allId $ flip S.notMember dom) ts - where - dom = M.foldrWithKey f S.empty r -- The domain of r - f x (I y) dom - | x == y = dom -- Ignore trivial bindings - | otherwise = S.insert x dom - f x _ dom = S.insert x dom - -allId :: (Id -> Bool) -> Term -> Bool -allId f (I x) = f x -allId _ (C _) = True -allId f (F _ u) = all (allId f) u - --- Cast an environment into a substitution by filtering out trivial --- bindings. - -substitution :: Env -> Subst -substitution (Env r) = - Subst $ M.filterWithKey nonTrivialBinding r - --- Add type information to an environment, and return it as a list of --- associations. - -reify :: [Term] -> Env -> [(Term, Term)] -reify domain (Env env) = - map (loop domain) $ M.assocs env - where - loop [] (x, _) = - error $ "Algebra.reify: variable missing from domain " ++ idName x - loop (I x : _) (y, t) - | x == y = (I x, t) - loop (F Text [I x] : _) (y, t) - | x == y = (F Text [I x], F Text [t]) - loop (F Data [I x] : _) (y, t) - | x == y = (F Data [I x], F Data [t]) - loop (F Name [I x] : _) (y, t) - | x == y = (F Name [I x], F Name [t]) - loop (F Skey [I x] : _) (y, t) - | x == y = (F Skey [I x], F Skey [t]) - loop (F Akey [I x] : _) (y, t) - | x == y = (F Akey [I x], F Akey [t]) - loop (F Base [I x] : _) (y, t) - | x == y = (F Base [I x], F Base [t]) - loop (F Expn [I x] : _) (y, t) - | x == y = (F Expn [I x], F Expn [t]) - loop (_ : domain) pair = loop domain pair - --- Ensure the range of an environment contains only variables and that --- the environment is injective. -matchRenaming :: Env -> Bool -matchRenaming (Env e) = - loop S.empty $ M.elems e - where - loop _ [] = True - loop s (I x:e) = - not (S.member x s) && loop (S.insert x s) e - loop _ _ = False - -instance C.Env Term Gen Subst Env where - emptyEnv = emptyEnv - instantiate = instantiate - match = match - identityEnvFor (g, e) ts = - if identityEnvFor e ts then - [(g, e)] - else - [] - specialize = id - substitution = substitution - reify = reify - matchRenaming (_, e) = matchRenaming e - --- Term specific loading functions - -loadVars :: Monad m => Gen -> [SExpr Pos] -> m (Gen, [Term]) -loadVars gen sexprs = - do - pairs <- mapM loadVarPair sexprs - (g, vars) <- foldM loadVar (gen, []) (concat pairs) - return (g, reverse vars) - -loadVarPair :: Monad m => SExpr Pos -> m [(SExpr Pos, SExpr Pos)] -loadVarPair (L _ (x:xs)) = - let (t:vs) = reverse (x:xs) in - return [(v,t) | v <- reverse vs] -loadVarPair x = fail (shows (annotation x) "Bad variable declaration") - -loadVar :: Monad m => (Gen, [Term]) -> (SExpr Pos, SExpr Pos) -> - m (Gen, [Term]) -loadVar (gen, vars) (S pos name, S pos' sort) = - case loadLookup pos vars name of - Right _ -> - fail (shows pos "Duplicate variable declaration for " ++ name) - Left _ -> - do - let (gen', x) = freshId gen name - p <- mkVar (I x) - return (gen', p : vars) - where - mkVar t = - case sort of - "mesg" -> return t - "text" -> return $ F Text [t] - "data" -> return $ F Data [t] - "name" -> return $ F Name [t] - "skey" -> return $ F Skey [t] - "akey" -> return $ F Akey [t] - "base" -> return $ F Base [t] - "expn" -> return $ F Expn [t] - _ -> fail (shows pos' "Sort " ++ sort ++ " not recognized") -loadVar _ (x,_) = fail (shows (annotation x) "Bad variable syntax") - -loadLookup :: Pos -> [Term] -> String -> Either String Term -loadLookup pos [] name = Left (shows pos $ "Identifier " ++ name ++ " unknown") -loadLookup pos (t : u) name = - let name' = idName (varId t) in - if name' == name then Right t else loadLookup pos u name - -loadLookupName :: Monad m => Pos -> [Term] -> String -> m Term -loadLookupName pos vars name = - either fail f (loadLookup pos vars name) - where - f t@(F Name [I _]) = return t - f _ = fail (shows pos $ "Expecting " ++ name ++ " to be a name") - -loadLookupAkey :: Monad m => Pos -> [Term] -> String -> m Term -loadLookupAkey pos vars name = - either fail f (loadLookup pos vars name) - where - f t@(F Akey [I _]) = return t - f _ = fail (shows pos $ "Expecting " ++ name ++ " to be an akey") - --- Load term and check that it is well-formed. -loadTerm :: Monad m => [Term] -> SExpr Pos -> m Term -loadTerm vars (S pos s) = - either fail return (loadLookup pos vars s) -loadTerm _ (Q _ t) = - return (C t) -loadTerm vars (L pos (S _ s : l)) = - case lookup s loadDispatch of - Nothing -> fail (shows pos "Keyword " ++ s ++ " unknown") - Just f -> f pos vars l -loadTerm _ x = fail (shows (annotation x) "Malformed term") - -type LoadFunction m = Pos -> [Term] -> [SExpr Pos] -> m Term - -loadDispatch :: Monad m => [(String, LoadFunction m)] -loadDispatch = - [("pubk", loadPubk) - ,("privk", loadPrivk) - ,("invk", loadInvk) - ,("ltk", loadLtk) - ,("gen", loadGen) - ,("exp", loadExp) - ,("cat", loadCat) - ,("enc", loadEnc) - ,("hash", loadHash) - ] - --- Atom constructors: pubk privk invk ltk - -loadPubk :: Monad m => LoadFunction m -loadPubk _ vars [S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Pubk [I $ varId t]] -loadPubk _ vars [Q _ c, S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Pubk [C c, I $ varId t]] -loadPubk pos _ _ = fail (shows pos "Malformed pubk") - -loadPrivk :: Monad m => LoadFunction m -loadPrivk _ vars [S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Invk [F Pubk [I $ varId t]]] -loadPrivk _ vars [Q _ c, S pos s] = - do - t <- loadLookupName pos vars s - return $ F Akey [F Invk [F Pubk [C c, I $ varId t]]] -loadPrivk pos _ _ = fail (shows pos "Malformed privk") - -loadInvk :: Monad m => LoadFunction m -loadInvk _ vars [S pos s] = - do - t <- loadLookupAkey pos vars s - return $ F Akey [F Invk [I $ varId t]] -loadInvk pos _ _ = fail (shows pos "Malformed invk") - -loadLtk :: Monad m => LoadFunction m -loadLtk _ vars [S pos s, S pos' s'] = - do - t <- loadLookupName pos vars s - t' <- loadLookupName pos' vars s' - return $ F Skey [F Ltk [I $ varId t, I $ varId t']] -loadLtk pos _ _ = fail (shows pos "Malformed ltk") - --- Base and exponents - -loadGen :: Monad m => LoadFunction m -loadGen _ _ [] = - return $ F Base [F Genr []] -loadGen pos _ _ = fail (shows pos "Malformed gen") - -loadExp :: Monad m => LoadFunction m -loadExp _ vars [x, x'] = - do - t <- loadBase vars x - t' <- loadExpn vars x' - return $ F Base [F Exp [t, t']] -loadExp pos _ _ = fail (shows pos "Malformed exp") - -loadBase :: Monad m => [Term] -> SExpr Pos -> m Term -loadBase vars x = - do - t <- loadTerm vars x - case t of - F Base [t] -> return t - _ -> fail (shows (annotation x) "Malformed base") - -loadExpn :: Monad m => [Term] -> SExpr Pos -> m Term -loadExpn vars x = - do - t <- loadTerm vars x - case t of - F Expn [t] -> return t - _ -> fail (shows (annotation x) "Malformed expn") - --- Term constructors: cat enc - -loadCat :: Monad m => LoadFunction m -loadCat _ vars (l : ls) = - do - ts <- mapM (loadTerm vars) (l : ls) - return $ foldr1 (\a b -> F Cat [a, b]) ts -loadCat pos _ _ = fail (shows pos "Malformed cat") - -loadEnc :: Monad m => LoadFunction m -loadEnc pos vars (l : l' : ls) = - do - let (butLast, last) = splitLast l (l' : ls) - t <- loadCat pos vars butLast - t' <- loadTerm vars last - return $ F Enc [t, t'] -loadEnc pos _ _ = fail (shows pos "Malformed enc") - -splitLast :: a -> [a] -> ([a], a) -splitLast x xs = - loop [] x xs - where - loop z x [] = (reverse z, x) - loop z x (y : ys) = loop (x : z) y ys - -loadHash :: Monad m => LoadFunction m -loadHash _ vars (l : ls) = - do - ts <- mapM (loadTerm vars) (l : ls) - return $ F Hash [foldr1 (\a b -> F Cat [a, b]) ts] -loadHash pos _ _ = fail (shows pos "Malformed hash") - --- Term specific displaying functions - -newtype Context = Context [(Id, String)] deriving Show - -displayVars :: Context -> [Term] -> [SExpr ()] -displayVars _ [] = [] -displayVars ctx vars = - let (v,t):pairs = map (displayVar ctx) vars in - loop t [v] pairs - where - loop t vs [] = [L () (reverse (t:vs))] - loop t vs ((v',t'):xs) - | t == t' = loop t (v':vs) xs - | otherwise = L () (reverse (t:vs)):loop t' [v'] xs - -displayVar :: Context -> Term -> (SExpr (), SExpr ()) -displayVar ctx (I x) = displaySortId "mesg" ctx x -displayVar ctx (F Text [I x]) = displaySortId "text" ctx x -displayVar ctx (F Data [I x]) = displaySortId "data" ctx x -displayVar ctx (F Name [I x]) = displaySortId "name" ctx x -displayVar ctx (F Skey [I x]) = displaySortId "skey" ctx x -displayVar ctx (F Akey [I x]) = displaySortId "akey" ctx x -displayVar ctx (F Base [I x]) = displaySortId "base" ctx x -displayVar ctx (F Expn [I x]) = displaySortId "expn" ctx x -displayVar _ _ = - error "Algebra.displayVar: term not a variable with its sort" - -displaySortId :: String -> Context -> Id -> (SExpr (), SExpr ()) -displaySortId sort ctx x = (displayId ctx x, S () sort) - -displayId :: Context -> Id -> SExpr () -displayId (Context ctx) x = - case lookup x ctx of - Nothing -> - let msg = idName x ++ " in a display context" in - error $ "Algebra.displayId: Cannot find variable " ++ msg - Just name -> S () name - -displayTerm :: Context -> Term -> SExpr () -displayTerm ctx (I x) = displayId ctx x -displayTerm ctx (F Text [I x]) = displayId ctx x -displayTerm ctx (F Data [I x]) = displayId ctx x -displayTerm ctx (F Name [I x]) = displayId ctx x -displayTerm ctx (F Skey [I x]) = displayId ctx x -displayTerm ctx (F Skey [F Ltk [I x, I y]]) = - L () [S () "ltk", displayId ctx x, displayId ctx y] -displayTerm ctx (F Akey [t]) = - case t of - I x -> displayId ctx x - F Invk [I x] -> L () [S () "invk", displayId ctx x] - F Pubk [I x] -> L () [S () "pubk", displayId ctx x] - F Pubk [C c, I x] -> L () [S () "pubk", Q () c, displayId ctx x] - F Invk [F Pubk [I x]] -> L () [S () "privk", displayId ctx x] - F Invk [F Pubk [C c, I x]] -> - L () [S () "privk", Q () c, displayId ctx x] - _ -> error ("Algebra.displayAkey: Bad term " ++ show t) -displayTerm ctx (F Expn [I x]) = displayId ctx x -displayTerm ctx (F Base [t]) = - displayExp t - where - displayExp (I x) = displayId ctx x - displayExp (F Genr []) = - L () [S () "gen"] - displayExp (F Exp [F Exp [x, y], z]) | y > z = - displayExp (F Exp [F Exp [x, z], y]) - displayExp (F Exp [x, y]) = - L () [S () "exp", displayTerm ctx (F Base [x]), - displayTerm ctx (F Expn [y])] - displayExp _ = error ("Algebra.displayTerm: Bad term " ++ show t) -displayTerm _ (C t) = Q () t -displayTerm ctx (F Cat [t0, t1]) = - L () (S () "cat" : displayTerm ctx t0 : displayList ctx t1) -displayTerm ctx (F Enc [t0, t1]) = - L () (S () "enc" : displayEnc ctx t0 t1) -displayTerm ctx (F Hash [t]) = - L () (S () "hash" : displayList ctx t) -displayTerm _ t = error ("Algebra.displayTerm: Bad term " ++ show t) - -displayList :: Context -> Term -> [SExpr ()] -displayList ctx (F Cat [t0, t1]) = displayTerm ctx t0 : displayList ctx t1 -displayList ctx t = [displayTerm ctx t] - -displayEnc :: Context -> Term -> Term -> [SExpr ()] -displayEnc ctx (F Cat [t0, t1]) t = displayTerm ctx t0 : displayEnc ctx t1 t -displayEnc ctx t0 t1 = [displayTerm ctx t0, displayTerm ctx t1] - -displayEnv :: Context -> Context -> Env -> [SExpr ()] -displayEnv ctx ctx' (Env r) = - map (\(x, t) -> L () [displayTerm ctx x, displayTerm ctx' t]) r' - where - r' = map (\(x, t) -> (I x, inferSort t)) $ M.assocs r - --- displaySubst c s displays a substitution s in context c, where some --- variables that occur in s might not be in c. Enough sort --- inference is performed so as to allow the extension of the context. -displaySubst :: Context -> Subst -> [SExpr ()] -displaySubst ctx s@(Subst r) = - map (\(x, t) -> L () [displayTerm ctx' x, displayTerm ctx' t]) r' - where - r' = map (\(x, t) -> (I x, inferSort (substitute s t))) $ M.assocs r - ctx' = foldl (\ctx (x, t) -> addToContext ctx [x, t]) ctx r' - -inferSort :: Term -> Term -inferSort t@(F Invk _) = F Akey [t] -inferSort t@(F Pubk _) = F Akey [t] -inferSort t@(F Ltk _) = F Skey [t] -inferSort t@(F Genr _) = F Base [t] -inferSort t@(F Exp _) = F Base [t] -inferSort t = t - -emptyContext :: Context -emptyContext = Context [] - --- Generate names for output renaming as necessary. --- Assumes the input is a list of term that are well-formed -addToContext :: Context -> [Term] -> Context -addToContext ctx u = - foldl (foldVars varContext) ctx u - -varContext :: Context -> Term -> Context -varContext ctx t = - let x = varId t - name = rootName $ idName x in - if hasId ctx x then - ctx - else - if hasName ctx name then - extendContext ctx x (genName ctx name) - else - extendContext ctx x name - -hasId :: Context -> Id -> Bool -hasId (Context ctx) id = - maybe False (const True) (lookup id ctx) - -hasName :: Context -> String -> Bool -hasName (Context ctx) name = - maybe False (const True) (L.find ((name ==) . snd) ctx) - -extendContext :: Context -> Id -> String -> Context -extendContext (Context ctx) x name = - Context $ (x, name) : ctx - -genName :: Context -> String -> String -genName ctx name = - loop 0 - where - root = '-' : reverse name - loop :: Int -> String - loop n = - let name' = revapp root (show n) in - if hasName ctx name' then - loop (n + 1) - else - name' - revapp [] s = s - revapp (c : cs) s = revapp cs (c : s) - -rootName :: String -> String -rootName name = - noHyphen 0 name - where - noHyphen _ [] = name - noHyphen i (c : s) - | c == '-' = hyphen i (i + 1) s - | otherwise = noHyphen (i + 1) s - hyphen i _ [] = rootName $ take i name - hyphen i j (c : s) - | isDigit c = hyphen i (j + 1) s - | otherwise = noHyphen j (c : s) - -instance C.Context Term Gen Subst Env Context where - emptyContext = emptyContext - addToContext = addToContext - displayVars = displayVars - displayTerm = displayTerm - displayEnv = displayEnv - displaySubst = displaySubst - -instance C.Algebra Term Place Gen Subst Env Context diff --git a/tst/DH_hack.tst b/tst/DH_hack.tst --- a/tst/DH_hack.tst +++ b/tst/DH_hack.tst @@ -1,6 +1,6 @@ (herald "DH Hack" (bound 15)) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from DH_hack.scm") (comment "Strand count bounded at 15") diff --git a/tst/blanchet.tst b/tst/blanchet.tst --- a/tst/blanchet.tst +++ b/tst/blanchet.tst @@ -1,7 +1,7 @@ (herald "Blanchet's Simple Example Protocol" (comment "There is a flaw in this protocol by design")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from blanchet.scm") (defprotocol blanchet basic diff --git a/tst/completeness-test.tst b/tst/completeness-test.tst --- a/tst/completeness-test.tst +++ b/tst/completeness-test.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from completeness-test.scm") (defprotocol completeness-test basic diff --git a/tst/crushing.tst b/tst/crushing.tst --- a/tst/crushing.tst +++ b/tst/crushing.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from crushing.scm") (defprotocol crushing basic diff --git a/tst/dass_simple.tst b/tst/dass_simple.tst --- a/tst/dass_simple.tst +++ b/tst/dass_simple.tst @@ -1,6 +1,6 @@ (herald "Distributed Authentication Security Service Protocol Variants") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from dass_simple.scm") (defprotocol dass-simple basic diff --git a/tst/denning-sacco.tst b/tst/denning-sacco.tst --- a/tst/denning-sacco.tst +++ b/tst/denning-sacco.tst @@ -1,6 +1,6 @@ (herald "Denning-Sacco Protocol") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from denning-sacco.scm") (defprotocol denning-sacco basic diff --git a/tst/deorig_contract.tst b/tst/deorig_contract.tst --- a/tst/deorig_contract.tst +++ b/tst/deorig_contract.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from deorig_contract.scm") (defprotocol deorig-contract basic diff --git a/tst/deorig_mesg.tst b/tst/deorig_mesg.tst --- a/tst/deorig_mesg.tst +++ b/tst/deorig_mesg.tst @@ -1,6 +1,6 @@ (herald deorig-mesg) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from deorig_mesg.scm") (defprotocol deorig-mesg basic diff --git a/tst/deorig_simple.tst b/tst/deorig_simple.tst --- a/tst/deorig_simple.tst +++ b/tst/deorig_simple.tst @@ -1,6 +1,6 @@ (herald deorig-simple) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from deorig_simple.scm") (defprotocol deorig-simple basic diff --git a/tst/dy.tst b/tst/dy.tst --- a/tst/dy.tst +++ b/tst/dy.tst @@ -1,6 +1,6 @@ (herald "Example 1.3 from 1983 Dolev-Yao Paper") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from dy.lsp") (defprotocol dy basic diff --git a/tst/encsig.tst b/tst/encsig.tst --- a/tst/encsig.tst +++ b/tst/encsig.tst @@ -1,7 +1,7 @@ (herald "Encrypted Signed Message Example" (comment "Shows examples of key usage of asymmetric keys")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from encsig.scm") (defprotocol mult-keys-enc-sig basic diff --git a/tst/epmo-hash.tst b/tst/epmo-hash.tst --- a/tst/epmo-hash.tst +++ b/tst/epmo-hash.tst @@ -1,7 +1,7 @@ (herald "Electronic Purchase with Money Order Protocol with Key Hashing" (comment "Annotated with trust management formulas")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from epmo-hash.scm") (defprotocol epmo basic diff --git a/tst/epmo-key-hash.tst b/tst/epmo-key-hash.tst --- a/tst/epmo-key-hash.tst +++ b/tst/epmo-key-hash.tst @@ -1,7 +1,7 @@ (herald "Electronic Purchase with Money Order Protocol with Key Hashing" (comment "Annotated with trust management formulas")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from epmo-key-hash.scm") (defprotocol epmo basic diff --git a/tst/epmo.tst b/tst/epmo.tst --- a/tst/epmo.tst +++ b/tst/epmo.tst @@ -1,7 +1,7 @@ (herald "Electronic Purchase with Money Order Protocol" (comment "Annotated with trust management formulas")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from epmo.scm") (defprotocol epmo basic diff --git a/tst/epmo_acctnum-key-hash.tst b/tst/epmo_acctnum-key-hash.tst --- a/tst/epmo_acctnum-key-hash.tst +++ b/tst/epmo_acctnum-key-hash.tst @@ -2,7 +2,7 @@ "Electronic Purchase with Money Order Protocol Variant with Key Hashing" (comment "This version includes account numbers in exchanges")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from epmo_acctnum-key-hash.scm") (defprotocol epmo_acctnum basic diff --git a/tst/ffgg.tst b/tst/ffgg.tst --- a/tst/ffgg.tst +++ b/tst/ffgg.tst @@ -1,7 +1,7 @@ (herald "The ffgg Protocol" (comment "From A Necessarily Parallel Attack by Jon K. Millen")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from ffgg.scm") (defprotocol ffgg basic diff --git a/tst/fragile_pruning.tst b/tst/fragile_pruning.tst --- a/tst/fragile_pruning.tst +++ b/tst/fragile_pruning.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from fragile_pruning.scm") (defprotocol fragile_pruning basic diff --git a/tst/hashtest-key-hash.tst b/tst/hashtest-key-hash.tst --- a/tst/hashtest-key-hash.tst +++ b/tst/hashtest-key-hash.tst @@ -1,6 +1,6 @@ (herald "Hashtest") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from hashtest-key-hash.scm") (defprotocol hashtest basic diff --git a/tst/hashtest.tst b/tst/hashtest.tst --- a/tst/hashtest.tst +++ b/tst/hashtest.tst @@ -1,6 +1,6 @@ (herald "Hashtest") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from hashtest.scm") (defprotocol hashtest basic diff --git a/tst/incompleteness_example.tst b/tst/incompleteness_example.tst --- a/tst/incompleteness_example.tst +++ b/tst/incompleteness_example.tst @@ -1,7 +1,7 @@ (herald incompleteness-example (comment "Shows a shape not found by CPSA")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from incompleteness_example.scm") (defprotocol incompleteness-example basic diff --git a/tst/isoreject.tst b/tst/isoreject.tst --- a/tst/isoreject.tst +++ b/tst/isoreject.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from isoreject.scm") (defprotocol isoreject basic diff --git a/tst/kelly1.tst b/tst/kelly1.tst --- a/tst/kelly1.tst +++ b/tst/kelly1.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from kelly1.scm") (defprotocol kelly1 basic diff --git a/tst/kerberos.tst b/tst/kerberos.tst --- a/tst/kerberos.tst +++ b/tst/kerberos.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from kerberos.scm") (defprotocol kerberos basic diff --git a/tst/mass.tst b/tst/mass.tst --- a/tst/mass.tst +++ b/tst/mass.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from mass.lsp") (defprotocol mass basic diff --git a/tst/mass2.tst b/tst/mass2.tst --- a/tst/mass2.tst +++ b/tst/mass2.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from mass2.lsp") (defprotocol mass2 basic diff --git a/tst/missing_contraction.tst b/tst/missing_contraction.tst --- a/tst/missing_contraction.tst +++ b/tst/missing_contraction.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from missing_contraction.scm") (defprotocol missing-contraction basic diff --git a/tst/neuman-stubblebine-reauth.tst b/tst/neuman-stubblebine-reauth.tst --- a/tst/neuman-stubblebine-reauth.tst +++ b/tst/neuman-stubblebine-reauth.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from neuman-stubblebine-reauth.lsp") (defprotocol neuman-stubblebine-reauth basic diff --git a/tst/neuman-stubblebine.tst b/tst/neuman-stubblebine.tst --- a/tst/neuman-stubblebine.tst +++ b/tst/neuman-stubblebine.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from neuman-stubblebine.scm") (defprotocol neuman-stubblebine basic diff --git a/tst/no_contraction.tst b/tst/no_contraction.tst --- a/tst/no_contraction.tst +++ b/tst/no_contraction.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from no_contraction.scm") (defprotocol no-contraction basic diff --git a/tst/non_transforming.tst b/tst/non_transforming.tst --- a/tst/non_transforming.tst +++ b/tst/non_transforming.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from non_transforming.scm") (defprotocol non_transforming basic diff --git a/tst/nonaug-prune.tst b/tst/nonaug-prune.tst --- a/tst/nonaug-prune.tst +++ b/tst/nonaug-prune.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from nonaug-prune.scm") (defprotocol nonaug-prune basic diff --git a/tst/ns-l.tst b/tst/ns-l.tst --- a/tst/ns-l.tst +++ b/tst/ns-l.tst @@ -1,7 +1,7 @@ (herald "Needham-Schroeder-Low Public-Key Protocol" (comment "With deflistener's")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from ns-l.scm") (defprotocol ns basic diff --git a/tst/ns.tst b/tst/ns.tst --- a/tst/ns.tst +++ b/tst/ns.tst @@ -1,6 +1,6 @@ (herald "Needham-Schroeder Public-Key Protocol Variants") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from ns.scm") (defprotocol ns basic diff --git a/tst/nsl3.tst b/tst/nsl3.tst --- a/tst/nsl3.tst +++ b/tst/nsl3.tst @@ -1,6 +1,6 @@ (herald "Three Party Needham-Schroeder-Lowe Protocol") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from nsl3.scm") (defprotocol nsl3 basic diff --git a/tst/nsl4cm1.tst b/tst/nsl4cm1.tst # file too large to diff: tst/nsl4cm1.tst diff --git a/tst/nslsk.tst b/tst/nslsk.tst --- a/tst/nslsk.tst +++ b/tst/nslsk.tst @@ -1,6 +1,6 @@ (herald "Needham-Schroeder-Lowe Protocol with symmetric encryption") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from nslsk.scm") (defprotocol nslsk basic diff --git a/tst/or.tst b/tst/or.tst --- a/tst/or.tst +++ b/tst/or.tst @@ -1,7 +1,7 @@ (herald "Otway-Rees Protocol" (comment "Standard version using variables of sort mesg")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from or.scm") (defprotocol or basic diff --git a/tst/pca.tst b/tst/pca.tst --- a/tst/pca.tst +++ b/tst/pca.tst @@ -1,7 +1,7 @@ (herald "Privacy Certificate Authority" (bound 15) (comment "Generation of an Attestation Identity Certificate")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from pca.scm") (comment "Strand count bounded at 15") diff --git a/tst/pen-non-orig-test.tst b/tst/pen-non-orig-test.tst --- a/tst/pen-non-orig-test.tst +++ b/tst/pen-non-orig-test.tst @@ -1,6 +1,6 @@ (herald "pen-non-orig test") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from pen-non-orig-test.scm") (defprotocol pennonorigtest basic diff --git a/tst/pkinit.tst b/tst/pkinit.tst --- a/tst/pkinit.tst +++ b/tst/pkinit.tst @@ -1,6 +1,6 @@ (herald "Kerberos PK init") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from pkinit.scm") (defprotocol pkinit basic diff --git a/tst/preprocess.tst b/tst/preprocess.tst --- a/tst/preprocess.tst +++ b/tst/preprocess.tst @@ -1,6 +1,6 @@ (herald "Pre-processing test example: modified NS with two responders") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from preprocess.scm") (defprotocol ns basic diff --git a/tst/print.tst b/tst/print.tst --- a/tst/print.tst +++ b/tst/print.tst @@ -1,7 +1,7 @@ (herald "Print Test" (comment "See if read forms look like printed ones")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from print.scm") (defprotocol print-test basic diff --git a/tst/pruning1.tst b/tst/pruning1.tst --- a/tst/pruning1.tst +++ b/tst/pruning1.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from pruning1.scm") (defprotocol prune basic diff --git a/tst/sigenc.tst b/tst/sigenc.tst --- a/tst/sigenc.tst +++ b/tst/sigenc.tst @@ -1,7 +1,7 @@ (herald "Signed Encrypted Message Example" (comment "Shows examples of key usage of asymmetric keys")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from sigenc.scm") (defprotocol mult-keys-sig-enc basic diff --git a/tst/sorted_epmo_acctnum.tst b/tst/sorted_epmo_acctnum.tst --- a/tst/sorted_epmo_acctnum.tst +++ b/tst/sorted_epmo_acctnum.tst @@ -4,7 +4,7 @@ "This version uses sorts to avoid confusion" "between a nonce and other data")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from sorted_epmo_acctnum.scm") (comment "Strand count bounded at 12") diff --git a/tst/targetterms2.tst b/tst/targetterms2.tst --- a/tst/targetterms2.tst +++ b/tst/targetterms2.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from targetterms2.scm") (defprotocol targetterms2 basic diff --git a/tst/targetterms6.tst b/tst/targetterms6.tst --- a/tst/targetterms6.tst +++ b/tst/targetterms6.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from targetterms6.scm") (defprotocol targetterms6 basic diff --git a/tst/targetterms8.tst b/tst/targetterms8.tst --- a/tst/targetterms8.tst +++ b/tst/targetterms8.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from targetterms8.scm") (defprotocol targetterms8 basic diff --git a/tst/timestamping.tst b/tst/timestamping.tst --- a/tst/timestamping.tst +++ b/tst/timestamping.tst @@ -1,6 +1,6 @@ (herald timestamping-service) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from timestamping.scm") (defprotocol timestamping-service basic diff --git a/tst/uncarried_keys.tst b/tst/uncarried_keys.tst --- a/tst/uncarried_keys.tst +++ b/tst/uncarried_keys.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from uncarried_keys.scm") (defprotocol uncarried-keys basic diff --git a/tst/uo.tst b/tst/uo.tst --- a/tst/uo.tst +++ b/tst/uo.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from uo.scm") (defprotocol uniq-orig basic diff --git a/tst/wang-hash.tst b/tst/wang-hash.tst --- a/tst/wang-hash.tst +++ b/tst/wang-hash.tst @@ -1,6 +1,6 @@ (herald "Wang's Fair Exchange Protocol" (bound 10)) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from wang-hash.scm") (comment "Strand count bounded at 10") diff --git a/tst/wang-key-hash.tst b/tst/wang-key-hash.tst --- a/tst/wang-key-hash.tst +++ b/tst/wang-key-hash.tst @@ -1,6 +1,6 @@ (herald "Wang's Fair Exchange Protocol" (bound 10)) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from wang-key-hash.scm") (comment "Strand count bounded at 10") diff --git a/tst/weird.tst b/tst/weird.tst --- a/tst/weird.tst +++ b/tst/weird.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from weird.scm") (defprotocol weird basic diff --git a/tst/wide-mouth-frog-scyther.tst b/tst/wide-mouth-frog-scyther.tst --- a/tst/wide-mouth-frog-scyther.tst +++ b/tst/wide-mouth-frog-scyther.tst @@ -1,7 +1,7 @@ (herald "Wide-Mouth Frog Protocol from Scyther" (comment "This protocol has an infinite number of shapes")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from wide-mouth-frog-scyther.lsp") (defprotocol wide-mouth-frog basic diff --git a/tst/wide-mouth-frog.tst b/tst/wide-mouth-frog.tst --- a/tst/wide-mouth-frog.tst +++ b/tst/wide-mouth-frog.tst @@ -1,7 +1,7 @@ (herald "Wide-Mouth Frog Protocol" (comment "This protocol has an infinite number of shapes")) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from wide-mouth-frog.lsp") (defprotocol wide-mouth-frog basic diff --git a/tst/wonthull.tst b/tst/wonthull.tst --- a/tst/wonthull.tst +++ b/tst/wonthull.tst @@ -1,6 +1,6 @@ (herald wonthull (bound 9)) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from wonthull.scm") (comment "Strand count bounded at 9") diff --git a/tst/wonthull2.tst b/tst/wonthull2.tst --- a/tst/wonthull2.tst +++ b/tst/wonthull2.tst @@ -1,6 +1,6 @@ (herald wonthull2 (bound 9)) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from wonthull2.scm") (comment "Strand count bounded at 9") diff --git a/tst/wonthull3.tst b/tst/wonthull3.tst --- a/tst/wonthull3.tst +++ b/tst/wonthull3.tst @@ -1,4 +1,4 @@ -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from wonthull3.scm") (defprotocol wonthull3 basic diff --git a/tst/woolam.scm b/tst/woolam.scm --- a/tst/woolam.scm +++ b/tst/woolam.scm @@ -24,3 +24,54 @@ (defskeleton woolam (vars (n text) (a s name)) (defstrand resp 5 (a a) (s s)) (non-orig (ltk a s))) + + +(defprotocol woolam-msg basic + (defrole init (vars (a s name) (n text)) + (trace + (send a) + (recv n) + (send (enc n (ltk a s)))) + (non-orig (ltk a s))) + (defrole resp (vars (a s b name) (n text) (m mesg)) + (trace + (recv a) + (send n) + (recv m) + (send (enc a m (ltk b s))) + (recv (enc n (ltk b s)))) + (non-orig (ltk b s)) + (uniq-orig n)) + (defrole serv (vars (a s b name) (n text)) + (trace + (recv (enc a (enc n (ltk a s)) (ltk b s))) + (send (enc n (ltk b s)))))) + +(defskeleton woolam-msg (vars (a s name)) + (defstrand resp 5 (a a) (s s)) + (non-orig (ltk a s))) + +(defprotocol woolam-msg1 basic + (defrole init (vars (a s name) (n text)) + (trace + (send a) + (recv n) + (send (enc n (ltk a s)))) + (non-orig (ltk a s))) + (defrole resp (vars (a s b name) (n text) (m mesg)) + (trace + (recv a) + (send n) + (recv m) + (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s)))) + (non-orig (ltk b s)) + (uniq-orig n)) + (defrole serv (vars (a s b name) (n text)) + (trace + (recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s)))))) + +(defskeleton woolam-msg1 (vars (a s name)) + (defstrand resp 5 (a a) (s s)) + (non-orig (ltk a s))) diff --git a/tst/woolam.tst b/tst/woolam.tst --- a/tst/woolam.tst +++ b/tst/woolam.tst @@ -1,6 +1,6 @@ (herald "Woo-Lam Protocol") -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from woolam.scm") (defprotocol woolam basic @@ -98,5 +98,451 @@ (shape) (maps ((0) ((a a) (s s) (b b) (n n)))) (origs (n (0 1)))) + +(comment "Nothing left to do") + +(defprotocol woolam-msg basic + (defrole init + (vars (a s name) (n text)) + (trace (send a) (recv n) (send (enc n (ltk a s)))) + (non-orig (ltk a s))) + (defrole resp + (vars (a s b name) (n text) (m mesg)) + (trace (recv a) (send n) (recv m) (send (enc a m (ltk b s))) + (recv (enc n (ltk b s)))) + (non-orig (ltk b s)) + (uniq-orig n)) + (defrole serv + (vars (a s b name) (n text)) + (trace (recv (enc a (enc n (ltk a s)) (ltk b s))) + (send (enc n (ltk b s)))))) + +(defskeleton woolam-msg + (vars (m mesg) (n text) (a s b name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (traces + ((recv a) (send n) (recv m) (send (enc a m (ltk b s))) + (recv (enc n (ltk b s))))) + (label 4) + (unrealized (0 4)) + (origs (n (0 1))) + (comment "2 in cohort - 2 not yet seen")) + +(defskeleton woolam-msg + (vars (m mesg) (n text) (a s b name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand init 3 (n n) (a b) (s s)) + (precedes ((0 1) (1 1)) ((1 2) (0 4))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (added-strand init 3) (enc n (ltk b s)) + (0 4)) + (traces + ((recv a) (send n) (recv m) (send (enc a m (ltk b s))) + (recv (enc n (ltk b s)))) + ((send b) (recv n) (send (enc n (ltk b s))))) + (label 5) + (parent 4) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m m)))) + (origs (n (0 1)))) + +(defskeleton woolam-msg + (vars (m mesg) (n text) (a s b a-0 name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a-0) (s s) (b b)) + (precedes ((0 1) (1 0)) ((1 1) (0 4))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (added-strand serv 2) (enc n (ltk b s)) + (0 4)) + (traces + ((recv a) (send n) (recv m) (send (enc a m (ltk b s))) + (recv (enc n (ltk b s)))) + ((recv (enc a-0 (enc n (ltk a-0 s)) (ltk b s))) + (send (enc n (ltk b s))))) + (label 6) + (parent 4) + (unrealized (1 0)) + (comment "2 in cohort - 2 not yet seen")) + +(defskeleton woolam-msg + (vars (n text) (a s b name)) + (defstrand resp 5 (m (enc n (ltk a s))) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (precedes ((0 3) (1 0)) ((1 1) (0 4))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (displaced 2 0 resp 4) + (enc a-0 (enc n (ltk a-0 s)) (ltk b s)) (1 0)) + (traces + ((recv a) (send n) (recv (enc n (ltk a s))) + (send (enc a (enc n (ltk a s)) (ltk b s))) + (recv (enc n (ltk b s)))) + ((recv (enc a (enc n (ltk a s)) (ltk b s))) + (send (enc n (ltk b s))))) + (label 7) + (parent 6) + (unrealized (0 2)) + (comment "2 in cohort - 2 not yet seen")) + +(defskeleton woolam-msg + (vars (m mesg) (n n-0 text) (a s b a-0 name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a-0) (s s) (b b)) + (defstrand resp 4 (m (enc n (ltk a-0 s))) (n n-0) (a a-0) (s s) (b b)) + (precedes ((0 1) (2 2)) ((1 1) (0 4)) ((2 3) (1 0))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n n-0) + (operation encryption-test (added-strand resp 4) + (enc a-0 (enc n (ltk a-0 s)) (ltk b s)) (1 0)) + (traces + ((recv a) (send n) (recv m) (send (enc a m (ltk b s))) + (recv (enc n (ltk b s)))) + ((recv (enc a-0 (enc n (ltk a-0 s)) (ltk b s))) + (send (enc n (ltk b s)))) + ((recv a-0) (send n-0) (recv (enc n (ltk a-0 s))) + (send (enc a-0 (enc n (ltk a-0 s)) (ltk b s))))) + (label 8) + (parent 6) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m m)))) + (origs (n-0 (2 1)) (n (0 1)))) + +(defskeleton woolam-msg + (vars (n text) (a s b name)) + (defstrand resp 5 (m (enc n (ltk a s))) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand init 3 (n n) (a a) (s s)) + (precedes ((0 1) (2 1)) ((0 3) (1 0)) ((1 1) (0 4)) ((2 2) (0 2))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (added-strand init 3) (enc n (ltk a s)) + (0 2)) + (traces + ((recv a) (send n) (recv (enc n (ltk a s))) + (send (enc a (enc n (ltk a s)) (ltk b s))) + (recv (enc n (ltk b s)))) + ((recv (enc a (enc n (ltk a s)) (ltk b s))) + (send (enc n (ltk b s)))) + ((send a) (recv n) (send (enc n (ltk a s))))) + (label 9) + (parent 7) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m (enc n (ltk a s)))))) + (origs (n (0 1)))) + +(defskeleton woolam-msg + (vars (n text) (a s b a-0 name)) + (defstrand resp 5 (m (enc n (ltk a s))) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a-0) (s s) (b a)) + (precedes ((0 1) (2 0)) ((0 3) (1 0)) ((1 1) (0 4)) ((2 1) (0 2))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (added-strand serv 2) (enc n (ltk a s)) + (0 2)) + (traces + ((recv a) (send n) (recv (enc n (ltk a s))) + (send (enc a (enc n (ltk a s)) (ltk b s))) + (recv (enc n (ltk b s)))) + ((recv (enc a (enc n (ltk a s)) (ltk b s))) + (send (enc n (ltk b s)))) + ((recv (enc a-0 (enc n (ltk a-0 s)) (ltk a s))) + (send (enc n (ltk a s))))) + (label 10) + (parent 7) + (unrealized (2 0)) + (comment "1 in cohort - 1 not yet seen")) + +(defskeleton woolam-msg + (vars (n n-0 text) (a s b a-0 name)) + (defstrand resp 5 (m (enc n (ltk a s))) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a-0) (s s) (b a)) + (defstrand resp 4 (m (enc n (ltk a-0 s))) (n n-0) (a a-0) (s s) (b a)) + (precedes ((0 1) (3 2)) ((0 3) (1 0)) ((1 1) (0 4)) ((2 1) (0 2)) + ((3 3) (2 0))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n n-0) + (operation encryption-test (added-strand resp 4) + (enc a-0 (enc n (ltk a-0 s)) (ltk a s)) (2 0)) + (traces + ((recv a) (send n) (recv (enc n (ltk a s))) + (send (enc a (enc n (ltk a s)) (ltk b s))) + (recv (enc n (ltk b s)))) + ((recv (enc a (enc n (ltk a s)) (ltk b s))) + (send (enc n (ltk b s)))) + ((recv (enc a-0 (enc n (ltk a-0 s)) (ltk a s))) + (send (enc n (ltk a s)))) + ((recv a-0) (send n-0) (recv (enc n (ltk a-0 s))) + (send (enc a-0 (enc n (ltk a-0 s)) (ltk a s))))) + (label 11) + (parent 10) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m (enc n (ltk a s)))))) + (origs (n-0 (3 1)) (n (0 1)))) + +(comment "Nothing left to do") + +(defprotocol woolam-msg1 basic + (defrole init + (vars (a s name) (n text)) + (trace (send a) (recv n) (send (enc n (ltk a s)))) + (non-orig (ltk a s))) + (defrole resp + (vars (a s b name) (n text) (m mesg)) + (trace (recv a) (send n) (recv m) (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s)))) + (non-orig (ltk b s)) + (uniq-orig n)) + (defrole serv + (vars (a s b name) (n text)) + (trace (recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s)))))) + +(defskeleton woolam-msg1 + (vars (m mesg) (n text) (a s b name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (traces + ((recv a) (send n) (recv m) (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s))))) + (label 12) + (unrealized (0 4)) + (origs (n (0 1))) + (comment "3 in cohort - 3 not yet seen")) + +(defskeleton woolam-msg1 + (vars (n text) (a s b name)) + (defstrand resp 5 (m (cat a n)) (n n) (a a) (s s) (b b)) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (displaced 1 0 resp 4) (enc a n (ltk b s)) + (0 4)) + (traces + ((recv a) (send n) (recv (cat a n)) + (send (cat a b (enc a n (ltk b s)))) (recv (enc a n (ltk b s))))) + (label 13) + (parent 12) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m (cat a n))))) + (origs (n (0 1)))) + +(defskeleton woolam-msg1 + (vars (m mesg) (n n-0 text) (a s b a-0 name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand resp 4 (m (cat a n)) (n n-0) (a a-0) (s s) (b b)) + (precedes ((0 1) (1 2)) ((1 3) (0 4))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n n-0) + (operation encryption-test (added-strand resp 4) (enc a n (ltk b s)) + (0 4)) + (traces + ((recv a) (send n) (recv m) (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv a-0) (send n-0) (recv (cat a n)) + (send (cat a-0 b (enc a n (ltk b s)))))) + (label 14) + (parent 12) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m m)))) + (origs (n-0 (1 1)) (n (0 1)))) + +(defskeleton woolam-msg1 + (vars (m mesg) (n text) (a s b name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (precedes ((0 1) (1 0)) ((1 1) (0 4))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (added-strand serv 2) (enc a n (ltk b s)) + (0 4)) + (traces + ((recv a) (send n) (recv m) (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s))))) + (label 15) + (parent 12) + (unrealized (1 0)) + (comment "2 in cohort - 2 not yet seen")) + +(defskeleton woolam-msg1 + (vars (n text) (a s b name)) + (defstrand resp 5 (m (enc n (ltk a s))) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (precedes ((0 3) (1 0)) ((1 1) (0 4))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (displaced 2 0 resp 4) + (enc (enc n (ltk a s)) (ltk b s)) (1 0)) + (traces + ((recv a) (send n) (recv (enc n (ltk a s))) + (send (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s))))) + (label 16) + (parent 15) + (unrealized (0 2)) + (comment "2 in cohort - 2 not yet seen")) + +(defskeleton woolam-msg1 + (vars (m mesg) (n n-0 text) (a s b a-0 name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand resp 4 (m (enc n (ltk a s))) (n n-0) (a a-0) (s s) (b b)) + (precedes ((0 1) (2 2)) ((1 1) (0 4)) ((2 3) (1 0))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n n-0) + (operation encryption-test (added-strand resp 4) + (enc (enc n (ltk a s)) (ltk b s)) (1 0)) + (traces + ((recv a) (send n) (recv m) (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s)))) + ((recv a-0) (send n-0) (recv (enc n (ltk a s))) + (send (cat a-0 b (enc (enc n (ltk a s)) (ltk b s)))))) + (label 17) + (parent 15) + (unrealized (2 2)) + (comment "3 in cohort - 3 not yet seen")) + +(defskeleton woolam-msg1 + (vars (n text) (a s b name)) + (defstrand resp 5 (m (enc n (ltk a s))) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand init 3 (n n) (a a) (s s)) + (precedes ((0 1) (2 1)) ((0 3) (1 0)) ((1 1) (0 4)) ((2 2) (0 2))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n) + (operation encryption-test (added-strand init 3) (enc n (ltk a s)) + (0 2)) + (traces + ((recv a) (send n) (recv (enc n (ltk a s))) + (send (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s)))) + ((send a) (recv n) (send (enc n (ltk a s))))) + (label 18) + (parent 16) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m (enc n (ltk a s)))))) + (origs (n (0 1)))) + +(defskeleton woolam-msg1 + (vars (n n-0 text) (a s b a-0 name)) + (defstrand resp 5 (m (enc n (ltk a s))) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand resp 4 (m n) (n n-0) (a a-0) (s s) (b a)) + (precedes ((0 1) (2 2)) ((0 3) (1 0)) ((1 1) (0 4)) ((2 3) (0 2))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n n-0) + (operation encryption-test (added-strand resp 4) (enc n (ltk a s)) + (0 2)) + (traces + ((recv a) (send n) (recv (enc n (ltk a s))) + (send (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s)))) + ((recv a-0) (send n-0) (recv n) + (send (cat a-0 a (enc n (ltk a s)))))) + (label 19) + (parent 16) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m (enc n (ltk a s)))))) + (origs (n-0 (2 1)) (n (0 1)))) + +(defskeleton woolam-msg1 + (vars (m mesg) (n n-0 text) (a s b a-0 name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand resp 4 (m (enc n (ltk a s))) (n n-0) (a a-0) (s s) (b b)) + (defstrand init 3 (n n) (a a) (s s)) + (precedes ((0 1) (3 1)) ((1 1) (0 4)) ((2 3) (1 0)) ((3 2) (2 2))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n n-0) + (operation encryption-test (added-strand init 3) (enc n (ltk a s)) + (2 2)) + (traces + ((recv a) (send n) (recv m) (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s)))) + ((recv a-0) (send n-0) (recv (enc n (ltk a s))) + (send (cat a-0 b (enc (enc n (ltk a s)) (ltk b s))))) + ((send a) (recv n) (send (enc n (ltk a s))))) + (label 20) + (parent 17) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m m)))) + (origs (n-0 (2 1)) (n (0 1)))) + +(defskeleton woolam-msg1 + (vars (n n-0 text) (s b a name)) + (defstrand resp 5 (m n) (n n) (a b) (s s) (b b)) + (defstrand serv 2 (n n) (a b) (s s) (b b)) + (defstrand resp 4 (m (enc n (ltk b s))) (n n-0) (a a) (s s) (b b)) + (precedes ((0 3) (2 2)) ((1 1) (0 4)) ((2 3) (1 0))) + (non-orig (ltk b s)) + (uniq-orig n n-0) + (operation encryption-test (displaced 3 0 resp 4) (enc n (ltk a-0 s)) + (2 2)) + (traces + ((recv b) (send n) (recv n) (send (cat b b (enc n (ltk b s)))) + (recv (enc b n (ltk b s)))) + ((recv (cat b b (enc (enc n (ltk b s)) (ltk b s)))) + (send (enc b n (ltk b s)))) + ((recv a) (send n-0) (recv (enc n (ltk b s))) + (send (cat a b (enc (enc n (ltk b s)) (ltk b s)))))) + (label 21) + (parent 17) + (unrealized) + (shape) + (maps ((0) ((a b) (s s) (b b) (n n) (m n)))) + (origs (n (0 1)) (n-0 (2 1)))) + +(defskeleton woolam-msg1 + (vars (m mesg) (n n-0 n-1 text) (a s b a-0 a-1 name)) + (defstrand resp 5 (m m) (n n) (a a) (s s) (b b)) + (defstrand serv 2 (n n) (a a) (s s) (b b)) + (defstrand resp 4 (m (enc n (ltk a s))) (n n-0) (a a-0) (s s) (b b)) + (defstrand resp 4 (m n) (n n-1) (a a-1) (s s) (b a)) + (precedes ((0 1) (3 2)) ((1 1) (0 4)) ((2 3) (1 0)) ((3 3) (2 2))) + (non-orig (ltk a s) (ltk b s)) + (uniq-orig n n-0 n-1) + (operation encryption-test (added-strand resp 4) (enc n (ltk a s)) + (2 2)) + (traces + ((recv a) (send n) (recv m) (send (cat a b (enc m (ltk b s)))) + (recv (enc a n (ltk b s)))) + ((recv (cat a b (enc (enc n (ltk a s)) (ltk b s)))) + (send (enc a n (ltk b s)))) + ((recv a-0) (send n-0) (recv (enc n (ltk a s))) + (send (cat a-0 b (enc (enc n (ltk a s)) (ltk b s))))) + ((recv a-1) (send n-1) (recv n) + (send (cat a-1 a (enc n (ltk a s)))))) + (label 22) + (parent 17) + (unrealized) + (shape) + (maps ((0) ((a a) (s s) (b b) (n n) (m m)))) + (origs (n-1 (3 1)) (n-0 (2 1)) (n (0 1)))) (comment "Nothing left to do") diff --git a/tst/yahalom-6.3.6.tst b/tst/yahalom-6.3.6.tst --- a/tst/yahalom-6.3.6.tst +++ b/tst/yahalom-6.3.6.tst @@ -5,7 +5,7 @@ (url "http://www.eecs.umich.edu/acal/swerve/docs/49-1.pdf") (bound 15)) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from yahalom-6.3.6.scm") (comment "Strand count bounded at 15") diff --git a/tst/yahalom.tst b/tst/yahalom.tst --- a/tst/yahalom.tst +++ b/tst/yahalom.tst @@ -1,6 +1,6 @@ (herald "Yahalom Protocol Without Forwarding" (bound 15)) -(comment "CPSA 2.3.3") +(comment "CPSA 2.3.4") (comment "All input read from yahalom.scm") (comment "Strand count bounded at 15")