Theory Sec_Typing

(* Author: Tobias Nipkow *)

subsection "Security Typing of Commands"

theory Sec_Typing imports Sec_Type_Expr
begin

subsubsection "Syntax Directed Typing"

inductive sec_type :: "nat ⇒ com ⇒ bool" ("(_/ ⊢ _)" [0,0] 50) where
Skip:
  "l ⊢ SKIP" |
Assign:
  "⟦ sec x ≥ sec a;  sec x ≥ l ⟧ ⟹ l ⊢ x ::= a" |
Seq:
  "⟦ l ⊢ c⇩1;  l ⊢ c⇩2 ⟧ ⟹ l ⊢ c⇩1;;c⇩2" |
If:
  "⟦ max (sec b) l ⊢ c⇩1;  max (sec b) l ⊢ c⇩2 ⟧ ⟹ l ⊢ IF b THEN c⇩1 ELSE c⇩2" |
While:
  "max (sec b) l ⊢ c ⟹ l ⊢ WHILE b DO c"

code_pred (expected_modes: i => i => bool) sec_type .

value "0 ⊢ IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"
value "1 ⊢ IF Less (V ''x1'') (V ''x'') THEN ''x''  ::= N 0 ELSE SKIP"
value "2 ⊢ IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"

inductive_cases [elim!]:
  "l ⊢ x ::= a"  "l ⊢ c⇩1;;c⇩2"  "l ⊢ IF b THEN c⇩1 ELSE c⇩2"  "l ⊢ WHILE b DO c"


text‹An important property: anti-monotonicity.›

lemma anti_mono: "⟦ l ⊢ c;  l' ≤ l ⟧ ⟹ l' ⊢ c"
apply(induction arbitrary: l' rule: sec_type.induct)
apply (metis sec_type.intros(1))
apply (metis le_trans sec_type.intros(2))
apply (metis sec_type.intros(3))
apply (metis If le_refl sup_mono sup_nat_def)
apply (metis While le_refl sup_mono sup_nat_def)
done

lemma confinement: "⟦ (c,s) ⇒ t;  l ⊢ c ⟧ ⟹ s = t (< l)"
proof(induction rule: big_step_induct)
  case Skip thus ?case by simp
next
  case Assign thus ?case by auto
next
  case Seq thus ?case by auto
next
  case (IfTrue b s c1)
  hence "max (sec b) l ⊢ c1" by auto
  hence "l ⊢ c1" by (metis max.cobounded2 anti_mono)
  thus ?case using IfTrue.IH by metis
next
  case (IfFalse b s c2)
  hence "max (sec b) l ⊢ c2" by auto
  hence "l ⊢ c2" by (metis max.cobounded2 anti_mono)
  thus ?case using IfFalse.IH by metis
next
  case WhileFalse thus ?case by auto
next
  case (WhileTrue b s1 c)
  hence "max (sec b) l ⊢ c" by auto
  hence "l ⊢ c" by (metis max.cobounded2 anti_mono)
  thus ?case using WhileTrue by metis
qed


theorem noninterference:
  "⟦ (c,s) ⇒ s'; (c,t) ⇒ t';  0 ⊢ c;  s = t (≤ l) ⟧
   ⟹ s' = t' (≤ l)"
proof(induction arbitrary: t t' rule: big_step_induct)
  case Skip thus ?case by auto
next
  case (Assign x a s)
  have [simp]: "t' = t(x := aval a t)" using Assign by auto
  have "sec x >= sec a" using ‹0 ⊢ x ::= a› by auto
  show ?case
  proof auto
    assume "sec x ≤ l"
    with ‹sec x >= sec a› have "sec a ≤ l" by arith
    thus "aval a s = aval a t"
      by (rule aval_eq_if_eq_le[OF ‹s = t (≤ l)›])
  next
    fix y assume "y ≠ x" "sec y ≤ l"
    thus "s y = t y" using ‹s = t (≤ l)› by simp
  qed
next
  case Seq thus ?case by blast
next
  case (IfTrue b s c1 s' c2)
  have "sec b ⊢ c1" "sec b ⊢ c2" using ‹0 ⊢ IF b THEN c1 ELSE c2› by auto
  show ?case
  proof cases
    assume "sec b ≤ l"
    hence "s = t (≤ sec b)" using ‹s = t (≤ l)› by auto
    hence "bval b t" using ‹bval b s› by(simp add: bval_eq_if_eq_le)
    with IfTrue.IH IfTrue.prems(1,3) ‹sec b ⊢ c1›  anti_mono
    show ?thesis by auto
  next
    assume "¬ sec b ≤ l"
    have 1: "sec b ⊢ IF b THEN c1 ELSE c2"
      by(rule sec_type.intros)(simp_all add: ‹sec b ⊢ c1› ‹sec b ⊢ c2›)
    from confinement[OF ‹(c1, s) ⇒ s'› ‹sec b ⊢ c1›] ‹¬ sec b ≤ l›
    have "s = s' (≤ l)" by auto
    moreover
    from confinement[OF ‹(IF b THEN c1 ELSE c2, t) ⇒ t'› 1] ‹¬ sec b ≤ l›
    have "t = t' (≤ l)" by auto
    ultimately show "s' = t' (≤ l)" using ‹s = t (≤ l)› by auto
  qed
next
  case (IfFalse b s c2 s' c1)
  have "sec b ⊢ c1" "sec b ⊢ c2" using ‹0 ⊢ IF b THEN c1 ELSE c2› by auto
  show ?case
  proof cases
    assume "sec b ≤ l"
    hence "s = t (≤ sec b)" using ‹s = t (≤ l)› by auto
    hence "¬ bval b t" using ‹¬ bval b s› by(simp add: bval_eq_if_eq_le)
    with IfFalse.IH IfFalse.prems(1,3) ‹sec b ⊢ c2› anti_mono
    show ?thesis by auto
  next
    assume "¬ sec b ≤ l"
    have 1: "sec b ⊢ IF b THEN c1 ELSE c2"
      by(rule sec_type.intros)(simp_all add: ‹sec b ⊢ c1› ‹sec b ⊢ c2›)
    from confinement[OF big_step.IfFalse[OF IfFalse(1,2)] 1] ‹¬ sec b ≤ l›
    have "s = s' (≤ l)" by auto
    moreover
    from confinement[OF ‹(IF b THEN c1 ELSE c2, t) ⇒ t'› 1] ‹¬ sec b ≤ l›
    have "t = t' (≤ l)" by auto
    ultimately show "s' = t' (≤ l)" using ‹s = t (≤ l)› by auto
  qed
next
  case (WhileFalse b s c)
  have "sec b ⊢ c" using WhileFalse.prems(2) by auto
  show ?case
  proof cases
    assume "sec b ≤ l"
    hence "s = t (≤ sec b)" using ‹s = t (≤ l)› by auto
    hence "¬ bval b t" using ‹¬ bval b s› by(simp add: bval_eq_if_eq_le)
    with WhileFalse.prems(1,3) show ?thesis by auto
  next
    assume "¬ sec b ≤ l"
    have 1: "sec b ⊢ WHILE b DO c"
      by(rule sec_type.intros)(simp_all add: ‹sec b ⊢ c›)
    from confinement[OF ‹(WHILE b DO c, t) ⇒ t'› 1] ‹¬ sec b ≤ l›
    have "t = t' (≤ l)" by auto
    thus "s = t' (≤ l)" using ‹s = t (≤ l)› by auto
  qed
next
  case (WhileTrue b s1 c s2 s3 t1 t3)
  let ?w = "WHILE b DO c"
  have "sec b ⊢ c" using ‹0 ⊢ WHILE b DO c› by auto
  show ?case
  proof cases
    assume "sec b ≤ l"
    hence "s1 = t1 (≤ sec b)" using ‹s1 = t1 (≤ l)› by auto
    hence "bval b t1"
      using ‹bval b s1› by(simp add: bval_eq_if_eq_le)
    then obtain t2 where "(c,t1) ⇒ t2" "(?w,t2) ⇒ t3"
      using ‹(?w,t1) ⇒ t3› by auto
    from WhileTrue.IH(2)[OF ‹(?w,t2) ⇒ t3› ‹0 ⊢ ?w›
      WhileTrue.IH(1)[OF ‹(c,t1) ⇒ t2› anti_mono[OF ‹sec b ⊢ c›]
        ‹s1 = t1 (≤ l)›]]
    show ?thesis by simp
  next
    assume "¬ sec b ≤ l"
    have 1: "sec b ⊢ ?w" by(rule sec_type.intros)(simp_all add: ‹sec b ⊢ c›)
    from confinement[OF big_step.WhileTrue[OF WhileTrue.hyps] 1] ‹¬ sec b ≤ l›
    have "s1 = s3 (≤ l)" by auto
    moreover
    from confinement[OF ‹(WHILE b DO c, t1) ⇒ t3› 1] ‹¬ sec b ≤ l›
    have "t1 = t3 (≤ l)" by auto
    ultimately show "s3 = t3 (≤ l)" using ‹s1 = t1 (≤ l)› by auto
  qed
qed


subsubsection "The Standard Typing System"

text‹The predicate \<^prop>‹l ⊢ c› is nicely intuitive and executable. The
standard formulation, however, is slightly different, replacing the maximum
computation by an antimonotonicity rule. We introduce the standard system now
and show the equivalence with our formulation.›

inductive sec_type' :: "nat ⇒ com ⇒ bool" ("(_/ ⊢'' _)" [0,0] 50) where
Skip':
  "l ⊢' SKIP" |
Assign':
  "⟦ sec x ≥ sec a; sec x ≥ l ⟧ ⟹ l ⊢' x ::= a" |
Seq':
  "⟦ l ⊢' c⇩1;  l ⊢' c⇩2 ⟧ ⟹ l ⊢' c⇩1;;c⇩2" |
If':
  "⟦ sec b ≤ l;  l ⊢' c⇩1;  l ⊢' c⇩2 ⟧ ⟹ l ⊢' IF b THEN c⇩1 ELSE c⇩2" |
While':
  "⟦ sec b ≤ l;  l ⊢' c ⟧ ⟹ l ⊢' WHILE b DO c" |
anti_mono':
  "⟦ l ⊢' c;  l' ≤ l ⟧ ⟹ l' ⊢' c"

lemma sec_type_sec_type': "l ⊢ c ⟹ l ⊢' c"
apply(induction rule: sec_type.induct)
apply (metis Skip')
apply (metis Assign')
apply (metis Seq')
apply (metis max.commute max.absorb_iff2 nat_le_linear If' anti_mono')
by (metis less_or_eq_imp_le max.absorb1 max.absorb2 nat_le_linear While' anti_mono')


lemma sec_type'_sec_type: "l ⊢' c ⟹ l ⊢ c"
apply(induction rule: sec_type'.induct)
apply (metis Skip)
apply (metis Assign)
apply (metis Seq)
apply (metis max.absorb2 If)
apply (metis max.absorb2 While)
by (metis anti_mono)

subsubsection "A Bottom-Up Typing System"

inductive sec_type2 :: "com ⇒ level ⇒ bool" ("(⊢ _ : _)" [0,0] 50) where
Skip2:
  "⊢ SKIP : l" |
Assign2:
  "sec x ≥ sec a ⟹ ⊢ x ::= a : sec x" |
Seq2:
  "⟦ ⊢ c⇩1 : l⇩1;  ⊢ c⇩2 : l⇩2 ⟧ ⟹ ⊢ c⇩1;;c⇩2 : min l⇩1 l⇩2 " |
If2:
  "⟦ sec b ≤ min l⇩1 l⇩2;  ⊢ c⇩1 : l⇩1;  ⊢ c⇩2 : l⇩2 ⟧
  ⟹ ⊢ IF b THEN c⇩1 ELSE c⇩2 : min l⇩1 l⇩2" |
While2:
  "⟦ sec b ≤ l;  ⊢ c : l ⟧ ⟹ ⊢ WHILE b DO c : l"


lemma sec_type2_sec_type': "⊢ c : l ⟹ l ⊢' c"
apply(induction rule: sec_type2.induct)
apply (metis Skip')
apply (metis Assign' eq_imp_le)
apply (metis Seq' anti_mono' min.cobounded1 min.cobounded2)
apply (metis If' anti_mono' min.absorb2 min.absorb_iff1 nat_le_linear)
by (metis While')

lemma sec_type'_sec_type2: "l ⊢' c ⟹ ∃ l' ≥ l. ⊢ c : l'"
apply(induction rule: sec_type'.induct)
apply (metis Skip2 le_refl)
apply (metis Assign2)
apply (metis Seq2 min.boundedI)
apply (metis If2 inf_greatest inf_nat_def le_trans)
apply (metis While2 le_trans)
by (metis le_trans)

end