Require Import Coq.Logic.FunctionalExtensionality Coq.Arith.EqNat Coq.Vectors.Vector Coq.MSets.MSets Names Sets Fun.

Inductive config : Set :=
  | nil : config
  | create : name -> name -> config -> config
  | send : name -> name -> config
  | restrict : name -> config -> config
  | compose : config -> config -> config
  | caseof : name -> list (name * config) -> config
  | instantiate_1 : forall n, name -> Vector.t name n ->
                              name -> config ->
                              name -> Vector.t name n -> config
  | instantiate_2 : forall n, name -> name -> Vector.t name n ->
                              name -> config ->
                              name -> name -> Vector.t name n -> config.

Inductive ConfigName (x : name) : config -> Prop :=
  | send_name_1 : forall y, ConfigName x (send x y)
  | send_name_2 : forall y, ConfigName x (send y x)
  | create_name_1 : forall y p, ConfigName x (create x y p)
  | create_name_2 : forall y p, ConfigName x (create y x p)
  | create_name_p : forall y z p, ConfigName x p -> ConfigName x (create y z p)
  | compose_name_l : forall pl pr, ConfigName x pl -> ConfigName x (compose pl pr)
  | compose_name_r : forall pl pr, ConfigName x pr -> ConfigName x (compose pl pr)
  | restrict_name : forall p, ConfigName x (restrict x p)
  | restrict_name_p : forall y p, ConfigName x p -> ConfigName x (restrict y p)
  | caseof_name : forall l, ConfigName x (caseof x l)
  | caseof_name_h_fst : forall y c l, ConfigName x (caseof y ((x, c) :: l))
  | caseof_name_h_snd : forall y n c l, ConfigName x c -> ConfigName x (caseof y ((n, c) :: l))
  | caseof_name_t : forall y nc l, ConfigName x (caseof y l) -> ConfigName x (caseof y (nc :: l)).

Hint Constructors ConfigName.

Inductive ConfigBoundedName (x : name) : config -> Prop :=
  | create_bounded : forall y p, x <> y -> ConfigBoundedName x (create y x p)
  | create_bounded_p : forall y z p, ConfigBoundedName x p -> x <> y ->
                                     ConfigBoundedName x (create y z p)
  | compose_bounded_b : forall pl pr, ConfigBoundedName x pl ->
                                      ConfigBoundedName x pr ->
                                      ConfigBoundedName x (compose pl pr)
  | compose_bounded_l : forall pl pr, ConfigBoundedName x pl ->
                                      ~ ConfigName x pr ->
                                      ConfigBoundedName x (compose pl pr)
  | compose_bounded_r : forall pl pr, ConfigBoundedName x pr ->
                                      ~ ConfigName x pl ->
                                      ConfigBoundedName x (compose pl pr)
  | restrict_bounded : forall p, ConfigBoundedName x (restrict x p)
  | restrict_bounded_p : forall y p, ConfigBoundedName x p ->
                                     ConfigBoundedName x (restrict y p)
  | caseof_bounded_s : forall y n c l, ConfigBoundedName x c ->
                                       ~ ConfigName x (caseof y l) ->
                                       x <> n ->
                                       ConfigBoundedName x (caseof y ((n, c) :: l))
  | caseof_bounded_h : forall y n c l, ConfigBoundedName x c ->
                                       ConfigBoundedName x (caseof y l) ->
                                       x <> n ->
                                       ConfigBoundedName x (caseof y ((n, c) :: l))
  | caseof_bounded_t : forall y n c l, ConfigBoundedName x (caseof y l) ->
                                       ~ ConfigName x c ->
                                       x <> n ->
                                       ConfigBoundedName x (caseof y ((n, c) :: l)).

  (* | caseof_bounded_s : forall y n c, ConfigBoundedName x c -> *)
  (*                                    x <> y -> *)
  (*                                    x <> n -> *)
  (*                                    ConfigBoundedName x (caseof y ((n, c) :: List.nil)) *)
  (* | caseof_bounded_h : forall y n c l, ConfigBoundedName x c -> *)
  (*                                      ~ ConfigBoundedName x (caseof y l) -> *)
  (* | caseof_bounded_t : forall y n c l, ConfigBoundedName x (caseof y l) -> *)
  (*                                      x <> n -> *)
  (*                                      ConfigBoundedName x (caseof y ((n, c) :: l)) *)
  (* | caseof_bounded : forall y l, Forall (fun nc => ConfigBoundedName x (snd nc)) l -> *)
  (*                                ConfigBoundedName x (caseof y l). *)

Hint Constructors ConfigBoundedName.

Inductive ConfigFreeName (x : name) : config -> Prop :=
  | send_free_1 : forall y, ConfigFreeName x (send x y)
  | send_free_2 : forall y, ConfigFreeName x (send y x)
  | create_free : forall y p, ConfigFreeName x (create x y p)
  | create_free_p : forall y z p, ConfigFreeName x p -> x <> z -> ConfigFreeName x (create y z p)
  | compose_free_l : forall pl pr, ConfigFreeName x pl -> ConfigFreeName x (compose pl pr)
  | compose_free_r : forall pl pr, ConfigFreeName x pr -> ConfigFreeName x (compose pl pr)
  | restrict_free : forall r p, ConfigFreeName x p -> x <> r -> ConfigFreeName x (restrict r p)
  | caseof_free : forall l, ConfigFreeName x (caseof x l)
  | caseof_free_h_fst : forall y c l, ConfigFreeName x (caseof y ((x, c) :: l))
  | caseof_free_h_snd : forall y n c l, ConfigFreeName x c -> ConfigFreeName x (caseof y ((n, c) :: l))
  | caseof_free_t : forall y nc l, ConfigFreeName x (caseof y l) -> ConfigFreeName x (caseof y (nc :: l))
  | instantiate_1_free_x : forall n u v z p y,
                             ConfigFreeName x (instantiate_1 n u v z p x y)
  | instantiate_1_free_y : forall n u v z p x' y,
                             Vector.In x y ->
                             ConfigFreeName x (instantiate_1 n u v z p x' y)
  | instantiate_1_free_p : forall n u v z p x' y,
                             ConfigFreeName x p ->
                             x <> u ->
                             ~ Vector.In x v ->
                             x <> z ->
                             ConfigFreeName x (instantiate_1 n u v z p x' y)
  | instantiate_2_free_x_1 : forall n u1 u2 v z p x2 y,
                               ConfigFreeName x (instantiate_2 n u1 u2 v z p x x2 y)
  | instantiate_2_free_x_2 : forall n u1 u2 v z p x1 y,
                               ConfigFreeName x (instantiate_2 n u1 u2 v z p x1 x y)
  | instantiate_2_free_y : forall n u1 u2 v z p x1 x2 y,
                             Vector.In x y ->
                             ConfigFreeName x (instantiate_2 n u1 u2 v z p x1 x2 y)
  | instantiate_2_free_p : forall n u1 u2 v z p x1 x2 y,
                             ConfigFreeName x p ->
                             x <> u1 ->
                             x <> u2 ->
                             ~ Vector.In x v ->
                             x <> z ->
                             ConfigFreeName x (instantiate_2 n u1 u2 v z p x1 x2 y).

Hint Constructors ConfigFreeName.

(* Lemma config_name_dec : forall x p, {ConfigName x p} + {~ ConfigName x p}. *)
(* Proof. *)
(*   intros. *)
(*   induction p. *)
(*     right; intro. *)
(*     inversion H. *)

(*     inversion IHp. *)
(*       left; auto. *)

(*       destruct (name_dec x n). *)
(*         rewrite e; left; auto. *)

(*         destruct (name_dec x n0). *)
(*           rewrite e; left; auto. *)

(*           right; intro. *)
(*           inversion H0; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)

(*       destruct (name_dec x n0). *)
(*         rewrite e; left; auto. *)

(*         right; intro. *)
(*         inversion H; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)

(*       inversion IHp. *)
(*         left; auto. *)

(*         right; intro. *)
(*         inversion H0; auto. *)

(*     inversion IHp1; inversion IHp2. *)
(*       left; auto. *)

(*       left; auto. *)

(*       left; auto. *)

(*       right; intro. *)
(*       inversion H1; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)

(*       induction l. *)
(*         right; intro. *)
(*         inversion H. *)
(*           apply n0; auto. *)

(*         inversion IHl. *)
(*           left. *)
(*           inversion H; subst. *)
(*             auto. *)

(*             apply caseof_name_t; auto. *)

(*             apply caseof_name_t; auto. *)

(*             apply caseof_name_t; auto. *)

(*           destruct a. *)
(*           destruct (name_dec x n1). *)
(*             left; rewrite e; auto. *)

(*             destruct (config_name_dec x c). *)
(* Qed. *)

(* Lemma config_free_dec : forall x p, {ConfigFreeName x p} + {~ ConfigFreeName x p}. *)
(* Proof. *)
(*   intros. *)
(*   induction p. *)
(*     right; intro; inversion H. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)
(*       destruct (name_dec x n0). *)
(*         rewrite e; right; intro; inversion H; subst; auto. *)
(*         inversion IHp. *)
(*           left; auto. *)
(*           right; intro; inversion H0; subst; auto. *)

(*     destruct (name_dec x n); destruct (name_dec x n0). *)
(*       rewrite e; auto. *)
(*       rewrite e; auto. *)
(*       rewrite e; auto. *)
(*       right; intro; inversion H; subst; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; right; intro; inversion H; subst; auto. *)
(*       inversion IHp. *)
(*         left; auto. *)
(*         right; intro; inversion H0; subst; auto. *)

(*     inversion_clear IHp1; inversion_clear IHp2. *)
(*       left; auto. *)
(*       left; auto. *)
(*       left; auto. *)
(*       right; intro; inversion H1; subst; auto. *)
(* Qed. *)

(* Lemma config_bounded_prop : forall x p, ConfigBoundedName x p -> ConfigName x p. *)
(* Proof. *)
(*   intros. *)
(*   induction p; inversion H; subst; auto. *)
(* Qed. *)

(* Lemma config_free_prop : forall x p, ConfigFreeName x p -> ConfigName x p. *)
(* Proof. *)
(*   intros. *)
(*   induction p; inversion H; subst; auto. *)
(* Qed. *)

(* Lemma config_name_prop : forall x p, ConfigName x p -> *)
(*                                      (ConfigBoundedName x p <-> ~ ConfigFreeName x p) /\ *)
(*                                      (ConfigFreeName x p <-> ~ ConfigBoundedName x p). *)
(* Proof. *)
(*   intros. *)
(*   induction p. *)
(*     inversion H. *)

(*     inversion H; subst. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; subst; auto. *)

(*         absurd (ConfigFreeName n (create n n0 p)); auto. *)

(*         inversion H1; subst; auto. *)

(*         auto. *)

(*       split; split; intros; try intro. *)
(*         inversion H0; subst; inversion H1; subst; auto. *)

(*         apply create_bounded. *)
(*         intro; subst; apply H0; auto. *)

(*         inversion H0; subst; inversion H1; subst; auto. *)

(*         assert (n <> n0 -> False). *)
(*           intro. *)
(*           apply H0. *)
(*           auto. *)
(*         apply eq_name_double_neg in H1. *)
(*         rewrite H1; auto. *)

(*       apply IHp in H1. *)
(*       inversion_clear H1. *)
(*       split; split; intros; try intro. *)
(*         inversion H1; subst; inversion H3; subst; auto. *)
(*         apply H0 in H6; auto. *)

(*         assert (x <> n). *)
(*           intro; apply H1. *)
(*           rewrite H3; auto. *)
(*         destruct (beq_name x n0) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite <- Heqb. *)
(*           apply create_bounded; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           apply create_bounded_p. *)
(*             apply H0. *)
(*             intro. *)
(*             apply H1. *)
(*             apply create_free_p; auto. *)

(*             auto. *)

(*         inversion H1; subst; inversion H3; subst; auto. *)
(*         apply H0 in H6; auto. *)

(*         destruct (beq_name x n) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite Heqb; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           assert (x <> n0). *)
(*             intro. *)
(*             rewrite <- H3 in H1. *)
(*             apply H1. *)
(*             auto. *)
(*           apply create_free_p; auto. *)
(*           apply H2. *)
(*           intro. *)
(*           apply H1. *)
(*           auto. *)

(*     inversion_clear H; subst. *)
(*       split; split; intros; try intro. *)
(*         inversion H. *)

(*         exfalso; apply H; auto. *)

(*         inversion H0. *)

(*         auto. *)
(*       split; split; intros; try intro. *)
(*         inversion H. *)

(*         exfalso; apply H; auto. *)

(*         inversion H0. *)

(*         auto. *)

(*     inversion_clear H; subst. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; auto. *)

(*         auto. *)

(*         inversion H; auto. *)

(*         exfalso; apply H; auto. *)
(*       apply IHp in H0. *)
(*       clear IHp. *)
(*       inversion_clear H0. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; subst; inversion H2; subst; auto. *)
(*         apply H in H4; auto. *)

(*         destruct (beq_name x n) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite Heqb; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           apply restrict_bounded_p. *)
(*           apply H; intro. *)
(*           apply H0; apply restrict_free; auto. *)

(*         inversion H0; subst; inversion H2; subst; auto. *)
(*         apply H in H4; auto. *)

(*         destruct (beq_name x n) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite Heqb in H0. *)
(*           exfalso; apply H0; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           apply restrict_free; auto. *)
(*           apply H1. *)
(*           intro. *)
(*           apply H0; auto. *)

(*     inversion_clear H; subst. *)
(*       assert (ConfigName x p1); auto. *)
(*       apply IHp1 in H0. *)
(*       inversion_clear H0. *)
(*       split; split; intros; try intro. *)
(*         inversion_clear H0; subst; inversion_clear H3; subst; auto. *)
(*           apply H1 in H4; auto. *)

(*           assert (ConfigBoundedName x p2); auto. *)
(*           apply config_bounded_prop in H3. *)
(*           apply IHp2 in H3. *)
(*           inversion_clear H3. *)
(*           apply H6 in H5; auto. *)

(*           apply H1 in H0; auto. *)

(*           apply config_free_prop in H0; auto. *)

(*         assert (~ ConfigFreeName x p1 /\ ~ ConfigFreeName x p2). *)
(*           split. *)
(*             intro; apply H0; auto. *)
(*             intro; apply H0; auto. *)
(*         inversion_clear H3. *)
(*         apply H1 in H4. *)
(*         destruct (config_name_dec x p2). *)
(*           apply IHp2 in c. *)
(*           inversion_clear c. *)
(*           apply H3 in H5. *)
(*           auto. *)

(*           auto. *)

(*         inversion H0; subst; inversion H3; subst; auto. *)
(*           apply H1 in H7; auto. *)

(*           apply H1 in H7; auto. *)

(*           assert (ConfigBoundedName x p2); auto. *)
(*           apply config_bounded_prop in H4; apply IHp2 in H4. *)
(*           inversion_clear H4. *)
(*           apply H6 in H8; auto. *)

(*           apply config_free_prop in H5; auto. *)

(*         destruct (config_name_dec x p2). *)
(*           apply IHp2 in c. *)
(*           inversion_clear c. *)
(*           destruct (config_free_dec x p1); auto. *)
(*           destruct (config_free_dec x p2); auto. *)
(*           apply H1 in n. *)
(*           apply H3 in n0. *)
(*           exfalso; apply H0; auto. *)

(*           apply compose_free_l. *)
(*           apply H2. *)
(*           intro. *)
(*           apply H0. *)
(*           auto. *)

(*       assert (ConfigName x p2); auto. *)
(*       apply IHp2 in H0. *)
(*       inversion_clear H0. *)
(*       clear IHp2. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; subst; inversion H3; subst; auto. *)
(*           assert (ConfigBoundedName x p1); auto. *)
(*           apply config_bounded_prop in H4. *)
(*           apply IHp1 in H4. *)
(*           inversion_clear H4. *)
(*           apply H8 in H6; auto. *)

(*           apply H1 in H7; auto. *)

(*           apply config_free_prop in H5; auto. *)

(*           apply H1 in H5; auto. *)

(*         assert (~ ConfigFreeName x p1 /\ ~ ConfigFreeName x p2). *)
(*           split. *)
(*             intro; apply H0; auto. *)
(*             intro; apply H0; auto. *)
(*         inversion_clear H3. *)
(*         apply H1 in H5. *)
(*         destruct (config_name_dec x p1). *)
(*           apply IHp1 in c; inversion_clear c. *)
(*           apply H3 in H4. *)
(*           auto. *)

(*           auto. *)

(*         inversion H0; subst; inversion H3; subst; auto. *)
(*           assert (ConfigBoundedName x p1); auto. *)
(*           apply config_bounded_prop in H4; apply IHp1 in H4; inversion_clear H4. *)
(*           apply H6 in H7; auto. *)

(*           apply config_free_prop in H5; auto. *)

(*           apply H1 in H8; auto. *)

(*           apply H1 in H7; auto. *)

(*         destruct (config_free_dec x p1); auto. *)
(*         destruct (config_free_dec x p2); auto. *)
(*         destruct (config_name_dec x p1). *)
(*           apply IHp1 in c; inversion_clear c. *)
(*           apply H3 in n. *)
(*           apply H1 in n0. *)
(*           exfalso; apply H0; auto. *)

(*           apply compose_free_r. *)
(*           apply H2. *)
(*           intro. *)
(*           apply H0. *)
(*           auto. *)
(* Qed. *)


Require Import
        Coq.Vectors.Vector
        Coq.ZArith.ZArith
        Coq.Strings.Ascii
        Coq.Strings.String
        Coq.Bool.Bool
        Coq.Vectors.Vector
        Coq.Lists.List.

Require Import
        Fiat.Common.BoundedLookup
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Narcissus.Formats.DomainNameOpt
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple.

Require Import
        Bedrock.Word
        Bedrock.Memory.

Import Lists.List.ListNotations.
Import Vectors.Vector.VectorNotations.

Local Open Scope string_scope.
Local Open Scope Tuple_scope.
Local Open Scope vector_scope.

Require Export Fiat.Narcissus.Examples.DNS.SimpleRRecordTypes.

Section QTypes.

  (* DNS packet Query Types are a superset of RR Types. *)
  Definition QTypes :=
    ["TKEY"; (* Transaction Key 	[RFC2930] *)
     "TSIG"; (* Transaction Signature 	[RFC2845] *)
     "IXFR"; (* incremental transfer 	[RFC1995] *)
     "AXFR"; (* transfer of an entire zone 	[RFC1035][RFC5936] *)
     "MAILB"; (* mailbox-related RRs (MB, MG or MR) 	[RFC1035] *)
     "MAILA"; (* mail agent RRs (OBSOLETE - see MX) 	[RFC1035] *)
     "STAR" (*A request for all records the server/cache has available 	[RFC1035][RFC6895] *)
    ].

  Definition QType_Ws : t (word 16) 11 :=
    Eval simpl in RRecordType_Ws ++ Vector.map (natToWord 16)
                             [249; (*"TKEY" *)
                                250; (*"TSIG" *)
                                251; (*"IXFR" *)
                                252; (*"AXFR" *)
                                253;(*"MAILB" *)
                                254;(*"MAILA" *)
                                255 (* "STAR" *)].

  Definition QType := EnumType ((OurRRecordTypes(* ++ ExtraRRecordTypes) *) ++ QTypes)).

  Definition QType_inj (rr : RRecordType) : QType :=
    Fin.L _ rr.

  Definition beq_QType (a b : QType) : bool :=
    fin_beq a b.

  Definition QType_dec (a b : QType) :=
    fin_eq_dec a b.

  Lemma beq_QType_sym :
    forall rrT rrT', beq_QType rrT rrT' = beq_QType rrT' rrT.
  Proof.
    intros; eapply fin_beq_sym.
  Qed.

  Coercion QType_inj : RRecordType >-> QType.

  Definition QType_match (rtype : RRecordType) (qtype : QType) :=
    qtype = ```"STAR" \/ qtype = rtype.

End QTypes.

Section RRecordClass.

  Definition RRecordClasses :=
    [ "Internet"; (* (IN) 	[RFC1035] *)
        "Chaos"; (* (CH) 	[D. Moon, "Chaosnet", A.I. Memo 628, Massachusetts Institute of Technology Artificial Intelligence Laboratory, June 1981.] *)
        "Hesiod" (* (HS) 	[Dyer, S., and F. Hsu, "Hesiod", Project Athena Technical Plan - Name Service, April 1987.] *)
    ].

  Definition RRecordClass_Ws : t (word 16) 3 :=
    Eval simpl in Vector.map (natToWord 16)
                             [1; (* "IN" *)
                                3; (* "CH" *)
                                4 (* "Hesiod" *)].

  Definition RRecordClass := EnumType RRecordClasses.

  Definition beq_RRecordClass (a b : RRecordClass) : bool
    := fin_beq a b.

  Definition RRecordClass_dec (a b : RRecordClass) :=
    fin_eq_dec a b.

  (* DNS Packet Question Classes *)
  Definition QClass := EnumType (RRecordClasses ++ ["Any"]).

  Definition QClass_Ws : t (word 16) 4 :=
    Eval simpl in Vector.append
                    RRecordClass_Ws
                    [natToWord 16 255 (* "Any"*)].

  Definition QClass_inj (qclass : RRecordClass) : QClass :=
    Fin.L _ qclass.

  Definition beq_QClass (a b : QClass) : bool
    := fin_beq a b.

  Definition QClass_dec (a b : QClass) :=
    fin_eq_dec a b.

End RRecordClass.

Section ResponseCode.

    Definition ResponseCodes :=
    ["NoError";  (* No Error [RFC1035] *)
       "FormErr";  (* Format Error [RFC1035] *)
       "ServFail"; (* Server Failure [RFC1035] *)
       "NXDomain"; (* Non-Existent  Domain 	[RFC1035] *)
       "NotImp";   (* Not Implemented [RFC1035] *)
       "Refused";  (* Query Refused [RFC1035] *)
       "YXDomain"; (* Name Exists when it should not [RFC2136][RFC6672] *)
       "YXRRSet";  (* RR Set Exists when it should not 	[RFC2136] *)
       "NXRRSet";  (* RR Set that should exist does not 	[RFC2136] *)
       "NotAuth";  (* Server Not Authoritative for zone 	[RFC2136] *)
                   (* and Not Authorized [RFC2845] *)
       "NotZone" 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition RCODE_Ws : t (word 4) 11 :=
    Eval simpl in Vector.map (natToWord 4)
    [0;  (* No Error [RFC1035] *)
     1;  (* Format Error [RFC1035] *)
     2; (* Server Failure [RFC1035] *)
     3; (* Non-Existent  Domain 	[RFC1035] *)
     4;   (* Not Implemented [RFC1035] *)
     5;  (* Query Refused [RFC1035] *)
     6; (* Name Exists when it should not [RFC2136][RFC6672] *)
     7;  (* RR Set Exists when it should not 	[RFC2136] *)
     8;  (* RR Set that should exist does not 	[RFC2136] *)
     9;  (* Server Not Authoritative for zone 	[RFC2136] *)
         (* and Not Authorized [RFC2845] *)
     10 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition ResponseCode := EnumType ResponseCodes.

  Definition beq_ResponseCode (a b : ResponseCode) : bool
    := fin_beq a b.

  Definition ResponseCode_dec (a b : ResponseCode) :=
    fin_eq_dec a b.
End ResponseCode.

Section OpCode.

  Definition OpCodes :=
    ["Query";    (* RFC1035] *)
     "IQuery"; (* Inverse Query  OBSOLETE) [RFC3425] *)
     "Status"; (* [RFC1035] *)
     "Notify"  (* [RFC1996] [RFC2136] *)
    ].

  Definition OpCode := EnumType OpCodes.

  Definition Opcode_Ws : t (word 4) 4 :=
    Eval simpl in Vector.map (natToWord 4)
                             [0;    (* RFC1035] *)
                              1; (* Inverse Query  OBSOLETE) [RFC3425] *)
                              2; (* [RFC1035] *)
                              4  (* [RFC1996] [RFC2136] *)].

  Definition beq_OpCode (a b : OpCode) : bool
    := fin_beq a b.

  Definition OpCode_dec (a b : OpCode) :=
    fin_eq_dec a b.

End OpCode.

Section Packet.

  (* The question section of a DNS packet. *)
  Definition question :=
    @Tuple <
    "qname" :: DomainName,
    "qtype" :: QType,
    "qclass" :: QClass >%Heading.
  (* ["google", "com"] *)

  (* DNS Resource Records. *)
  Definition sRRecords := "ResourceRecords".
  Definition sNAME := "Name".
  Definition sTTL := "TTL".
  Definition sCLASS := "Class".
  Definition sTYPE := "Type".
  Definition sRDATA := "rdata".
  Definition sRLENGTH := "rlength".

  Definition resourceRecordHeading :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDataType>%Heading.

  Definition resourceRecord := @Tuple resourceRecordHeading.

  (* Variant headings for each RDataType *)
  Definition VariantResourceRecordHeading RDATAT :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDATAT >%Heading.

  Definition VariantResourceRecord RDATAT := @Tuple (VariantResourceRecordHeading RDATAT).

  (* Aliases for the Common Record Types *)
  Definition CNAME_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurCNAME].
  Definition A_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurA ].
  Definition NS_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurNS].
  Definition SOA_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurSOA].

  Definition RRecord2VariantResourceRecord
             (rr : resourceRecord)
    : VariantResourceRecord ResourceRecordTypeTypes[@(SumType_index ResourceRecordTypeTypes (rr!sRDATA))] :=
    < sNAME :: rr!sNAME,
      sTTL :: rr!sTTL,
      sCLASS :: rr!sCLASS,
      sRDATA :: SumType_proj _ (rr!sRDATA)>.

  Definition VariantResourceRecord2RRecord
             {idx}
             (vrr : VariantResourceRecord ResourceRecordTypeTypes[@idx])
    : resourceRecord :=
    < sNAME :: vrr!sNAME,
      sTTL :: vrr!sTTL,
      sCLASS :: vrr!sCLASS,
      sRDATA :: inj_SumType _ idx (vrr!sRDATA)>.

  Definition CNAME_Record2RRecord
             (vrr : CNAME_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition A_Record2RRecord
             (vrr : A_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition NS_Record2RRecord
             (vrr : NS_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition SOA_Record2RRecord
             (vrr : SOA_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.

  (* Binary Format of DNS Header:
                              1  1  1  1  1  1
0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                      ID                       |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|QR|   Opcode  |AA|TC|RD|RA|   Z    |   RCODE   |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    QDCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ANCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    NSCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ARCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
   *)

  (* DNS Packet Layout:
+---------------------+
|        Header       |
+---------------------+
|       Question      |
+---------------------+
|        Answer       |
+---------------------+
|      Authority      |
+---------------------+
|      Additional     |
+---------------------+
   *)

(* Unique Request IDs *)
Definition ID : Type := word 16.

  Definition packetHeading :=
    < "id" :: ID, (* 16 bit Word. *)
      "QR" :: bool, (* is packet a query (0), or a response (1) *)
      "Opcode" :: OpCode, (* kind of query in packet *)
      "AA" :: bool, (* is responding server authorative *)
      "TC" :: bool, (* is packet truncated *)
      "RD" :: bool, (* are recursive queries desired *)
      "RA" :: bool, (* are recursive queries supported by responding server *)
      "RCODE" :: ResponseCode, (* response code *)
      "question" :: question, (* `list question` in case we can have multiple questions? *)
      "answers" :: list resourceRecord,
      "authority" :: list resourceRecord,
      "additional" :: list resourceRecord >%Heading.

  Definition packet := @Tuple packetHeading.

  Definition buildempty (is_authority : bool)
             (rcode : BoundedIndex ResponseCodes)
             (p : packet) :=
    p ○ [ "AA" ::= is_authority; (* Update Authority field *)
          "QR" ::= true; (* Set response flag to true *)
          "RCODE" ::= ibound (indexb rcode);
          "answers" ::= nil;
          "authority"  ::= nil;
          "additional" ::= nil ].

  (* add a resource record to a packet's answers *)
  Definition add_answer (p : packet) (t : resourceRecord) :=
    p ○ [o !! "answers" / t :: o].

  (* add a resource record authority to a packet's authorities
   (ns = name server). *)
  Definition add_ns (p : packet) (t : resourceRecord) :=
    p ○ [o !! "authority" / t :: o].

  (* combine with above? *)
  Definition add_additional (p : packet) (t : resourceRecord) :=
    p ○ [o !! "additional" / t :: o].

  Definition updateRecords (p : packet) answers' authority' additional' :=
    p ○ ["answers" ::= answers';
           "authority" ::= authority';
           "additional" ::= additional'].

  Definition get_name (r : resourceRecord) := r!sNAME.
  Definition name_length (r : resourceRecord) := String.length (get_name r).

  Definition isQuestion (p : packet) :=
    match p!"answers", p!"authority", p!"additional" with
    | nil, nil, nil => true
    | _, _, _ => false
    end.

  Definition is_empty {A} (l : list A) : bool :=
    match l with
    | nil => true
    | _ => false
    end.

  Lemma is_empty_app {A} :
    forall (l l' : list A),
      is_empty (l ++ l') = andb (is_empty l) (is_empty l').
  Proof.
    induction l; simpl; eauto.
  Qed.

  Definition isAnswer (p : packet) := negb (is_empty (p!"answers")).

  Definition isReferral (p : packet) :=
    is_empty (p!"answers")
             && (negb (is_empty (p!"authority")))
             && (negb (is_empty (p!"additional"))).

  Definition add_answers := List.fold_left add_answer.
  Definition add_nses := List.fold_left add_ns.
  Definition add_additionals := List.fold_left add_additional.

End Packet.

Coercion CNAME_Record2RRecord : CNAME_Record >-> resourceRecord.
Coercion A_Record2RRecord : A_Record >-> resourceRecord.
Coercion NS_Record2RRecord : NS_Record >-> resourceRecord.
Coercion SOA_Record2RRecord : SOA_Record >-> resourceRecord.


Require Export SpecializedCommaCategory ProductCategory.
Require Import Common Notations.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Open Scope category_scope.

Section CommaCategory.
  Context `(A : @SpecializedCategory objA).
  Context `(B : @SpecializedCategory objB).
  Context `(C : @SpecializedCategory objC).
  Variable S : SpecializedFunctor A C.
  Variable T : SpecializedFunctor B C.

  Definition CommaCategoryProjection : SpecializedFunctor (S ↓ T) (A * B)
    := Build_SpecializedFunctor (S ↓ T) (A * B)
                                (@projT1 _ _)
                                (fun _ _ m => proj1_sig m)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).
End CommaCategory.

Section SliceCategory.
  Context `(A : @SpecializedCategory objA).

  Local Arguments ComposeFunctors' / .

  Definition ArrowCategoryProjection : SpecializedFunctor (ArrowSpecializedCategory A) A
    := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection _ (IdentityFunctor A)).

  Definition SliceCategoryOverProjection (a : A) : SpecializedFunctor (A / a) A
    := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection (IdentityFunctor A) _).

  Definition CosliceCategoryOverProjection (a : A) : SpecializedFunctor (a \ A) A
    := ComposeFunctors' snd_Functor (CommaCategoryProjection _ (IdentityFunctor A)).

  Section Slice_Coslice.
    Context `(C : @SpecializedCategory objC).
    Variable a : C.
    Variable S : SpecializedFunctor A C.

    Section Slice.
      Definition SliceCategoryProjection : SpecializedFunctor (S ↓ a) A
        := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection S (FunctorFromTerminal C a)).
    End Slice.

    Section Coslice.
      Definition CosliceCategoryProjection : SpecializedFunctor (a ↓ S) A
        := Eval simpl in ComposeFunctors' snd_Functor (CommaCategoryProjection (FunctorFromTerminal C a) S).
      Check CosliceCategoryProjection.
      Eval simpl in SpecializedFunctor (a ↓ S) A.
    End Coslice.
  End Slice_Coslice.
End SliceCategory.