1 files changed, 275 insertions, 0 deletions
diff --git a/ProtocolBuffers.hs b/ProtocolBuffers.hs
new file mode 100644
index 0000000..6d02096
--- /dev/null
+++ b/ProtocolBuffers.hs
@@ -0,0 +1,275 @@
+{-# LANGUAGE DeriveGeneric, DataKinds, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{- | Protocol buffers serialization for the debug-me wire protocol.
+ - 
+ - The message types in here define protocol buffers, so should be changed
+ - with care. These messages correspond to the main data types in the Types
+ - module.
+ -}
+
+module ProtocolBuffers where
+
+import qualified Types as T
+import Val
+
+import Data.ProtocolBuffers
+import GHC.Generics (Generic)
+import qualified Data.ByteString as B
+import Data.Monoid
+import Prelude
+
+data SeenP = SeenP
+	{ seenDataP :: Required 1 (Value B.ByteString)
+	}
+	deriving (Generic)
+
+data EnteredP = EnteredP
+	{ enteredDataP :: Required 2 (Value B.ByteString)
+	, echoDataP :: Required 3 (Value B.ByteString)
+	}
+	deriving (Generic)
+
+data MessageP a
+	= ActivityMessageP
+		{ activityMessageP :: Required 4 (Message (ActivityP a)) }
+	| ControlMessageP
+		{ controlMessageP :: Required 5 (Message ControlP) }
+	deriving (Generic)
+
+data ActivityP a = ActivityP
+	{ activityP :: Required 6 (Message a)
+	, prevAtivityP :: Optional 7 (Message HashP)
+	, elapsedTimeP :: Required 8 (Message ElapsedTimeP)
+	, activitySignatureP :: Required 9 (Message SignatureP)
+	}
+	deriving (Generic)
+
+data ControlP = ControlP
+	{ controlP :: Required 10 (Message ControlActionP)
+	, controlSignatureP ::Required 11 (Message SignatureP)
+	}
+	deriving (Generic)
+
+data ControlActionP
+	= RejectedP
+		{ rejectedP :: Required 12 (Message (ActivityP EnteredP)) }
+	| SessionKeyP
+		{ sessionKeyP :: Required 13 (Message (PerhapsSignedP PublicKeyP)) }
+	| SessionKeyAcceptedP
+		{ sessionKeyAcceptedP :: Required 14 (Message PublicKeyP) }
+	| SessionKeyRejectedP
+		{ sessionKeyRejectedP :: Required 15 (Message PublicKeyP) }
+	deriving (Generic)
+
+data HashP = HashP
+	{ hashMethodP :: Required 16 (Value B.ByteString)
+	, hashValueP :: Required 17 (Value B.ByteString)
+	}
+	deriving (Generic)
+
+data SignatureP
+	= Ed25519SignatureP
+		{ ed25519SignatureP :: Required 18 (Value B.ByteString) }
+	| OtherSignatureP
+		{ otherSignatureP :: Required 19 (Value B.ByteString) }
+	deriving (Generic)
+
+data PublicKeyP = PublicKeyP 
+	{ mkPublicKeyP :: Required 20 (Value B.ByteString) }
+	deriving (Generic)
+
+data PerhapsSignedP a
+	= GpgSignedP
+		{ gpgSignedValP :: Required 21 (Message a)
+		, gpgSigP :: Required 22 (Message GpgSigP)
+		}
+	| UnSignedP
+		{ mkUnSignedP :: Required 23 (Message a )
+		}
+	deriving (Generic)
+
+data GpgSigP = GpgSigP
+	{ mkGpgSigP :: Required 24 (Value B.ByteString) }
+	deriving (Generic)
+
+data ElapsedTimeP = ElapsedTimeP
+	{ mkElapsedTimeP :: Required 25 (Value Double) }
+	deriving (Generic)
+
+data AnyMessageP
+	= UserP { mkUserP :: Required 26 (Message (MessageP SeenP)) }
+	| DeveloperP { mkDeveloperP :: Required 27 (Message (MessageP EnteredP)) }
+	deriving (Generic)
+
+-- | Conversion between protocol buffer messages and debug-me's main Types.
+class ProtocolBuffer p t where
+	toProtocolBuffer :: t -> p
+	fromProtocolBuffer :: p -> t
+
+instance ProtocolBuffer SeenP T.Seen where
+	toProtocolBuffer t = SeenP
+		{ seenDataP = putField $ val $ T.seenData t
+		}
+	fromProtocolBuffer p =T.Seen
+		{ T.seenData = Val $ getField $ seenDataP p
+		}
+
+instance ProtocolBuffer EnteredP T.Entered where
+	toProtocolBuffer t = EnteredP
+		{ enteredDataP = putField $ val $ T.enteredData t
+		, echoDataP = putField $ val $ T.echoData t
+		}
+	fromProtocolBuffer p =T.Entered
+		{ T.enteredData = Val $ getField $ enteredDataP p
+		, T.echoData = Val $ getField $ echoDataP p
+		}
+
+instance ProtocolBuffer (ActivityP p) (T.Activity t) => ProtocolBuffer (MessageP p) (T.Message t) where
+	toProtocolBuffer (T.ActivityMessage a) =
+		ActivityMessageP (putField (toProtocolBuffer a))
+	toProtocolBuffer (T.ControlMessage c) = 
+		ControlMessageP (putField (toProtocolBuffer c))
+	fromProtocolBuffer p@(ActivityMessageP {}) =
+		T.ActivityMessage $ fromProtocolBuffer $
+			getField $ activityMessageP p
+	fromProtocolBuffer p@(ControlMessageP {}) =
+		T.ControlMessage $ fromProtocolBuffer $
+			getField $ controlMessageP p
+
+instance ProtocolBuffer p t => ProtocolBuffer (ActivityP p) (T.Activity t) where
+	toProtocolBuffer t = ActivityP
+		{ activityP = putField $ toProtocolBuffer $ T.activity t
+		, prevAtivityP = putField $ fmap toProtocolBuffer $ T.prevActivity t
+		, elapsedTimeP = putField $ toProtocolBuffer $ T.elapsedTime t
+		, activitySignatureP = putField $ toProtocolBuffer $ T.activitySignature t
+		}
+	fromProtocolBuffer p = T.Activity
+		{ T.activity = fromProtocolBuffer $ getField $ activityP p
+		, T.prevActivity = fmap fromProtocolBuffer $ getField $ prevAtivityP p
+		, T.elapsedTime = fromProtocolBuffer $ getField $ elapsedTimeP p
+		, T.activitySignature = fromProtocolBuffer $ getField $ activitySignatureP p
+		}
+
+instance ProtocolBuffer ControlP T.Control where
+	toProtocolBuffer t = ControlP
+		{ controlP = putField $ toProtocolBuffer $ T.control t
+		, controlSignatureP = putField $ toProtocolBuffer $ T.controlSignature t
+		}
+	fromProtocolBuffer p = T.Control
+		{ T.control = fromProtocolBuffer $ getField $ controlP p
+		, T.controlSignature = fromProtocolBuffer $ getField $ controlSignatureP p
+		}
+
+instance ProtocolBuffer ControlActionP T.ControlAction where
+	toProtocolBuffer (T.Rejected t) = RejectedP
+		{ rejectedP = putField $ toProtocolBuffer t }
+	toProtocolBuffer (T.SessionKey t) = SessionKeyP
+		{ sessionKeyP = putField $ toProtocolBuffer t }
+	toProtocolBuffer (T.SessionKeyAccepted t) = SessionKeyAcceptedP
+		{ sessionKeyAcceptedP = putField $ toProtocolBuffer t }
+	toProtocolBuffer (T.SessionKeyRejected t) = SessionKeyRejectedP
+		{ sessionKeyRejectedP = putField $ toProtocolBuffer t }
+	fromProtocolBuffer p@(RejectedP {}) = T.Rejected $
+		fromProtocolBuffer $ getField $ rejectedP p
+	fromProtocolBuffer p@(SessionKeyP {}) = T.SessionKey $
+		fromProtocolBuffer $ getField $ sessionKeyP p
+	fromProtocolBuffer p@(SessionKeyAcceptedP {}) = T.SessionKeyAccepted $
+		fromProtocolBuffer $ getField $ sessionKeyAcceptedP p
+	fromProtocolBuffer p@(SessionKeyRejectedP {}) = T.SessionKeyRejected $
+		fromProtocolBuffer $ getField $ sessionKeyRejectedP p
+
+instance ProtocolBuffer HashP T.Hash where
+	toProtocolBuffer t = HashP
+		{ hashMethodP = putField $ case T.hashMethod t of
+			T.SHA256 -> "2"
+			T.SHA3 -> "3"
+		, hashValueP = putField $ val $ T.hashValue t
+		}
+	fromProtocolBuffer p = T.Hash
+		{ T.hashMethod = case getField (hashMethodP p) of
+			"2" -> T.SHA256
+			"3" -> T.SHA3
+			_ -> T.SHA256
+		, T.hashValue = Val $ getField $ hashValueP p
+		}
+
+instance ProtocolBuffer SignatureP T.Signature where
+	toProtocolBuffer (T.Ed25519Signature t) = Ed25519SignatureP
+		{ ed25519SignatureP = putField $ val t }
+	toProtocolBuffer (T.OtherSignature t) = OtherSignatureP
+		{ otherSignatureP = putField $ val t }
+	fromProtocolBuffer p@(Ed25519SignatureP {}) = T.Ed25519Signature $
+		Val $ getField $ ed25519SignatureP p
+	fromProtocolBuffer p@(OtherSignatureP {}) = T.OtherSignature $
+		Val $ getField $ otherSignatureP p
+
+instance ProtocolBuffer PublicKeyP T.PublicKey where
+	toProtocolBuffer (T.PublicKey t) = PublicKeyP
+		{ mkPublicKeyP = putField (val t) }
+	fromProtocolBuffer p = T.PublicKey $ Val $ getField $ mkPublicKeyP p
+
+instance ProtocolBuffer p t => ProtocolBuffer (PerhapsSignedP p) (T.PerhapsSigned t) where
+	toProtocolBuffer (T.GpgSigned tv tg) = GpgSignedP
+		{ gpgSignedValP = putField $ toProtocolBuffer tv
+		, gpgSigP = putField $ toProtocolBuffer tg
+		}
+	toProtocolBuffer (T.UnSigned tv) = UnSignedP
+		{ mkUnSignedP = putField $ toProtocolBuffer tv
+		}
+	fromProtocolBuffer p@(GpgSignedP {}) = T.GpgSigned
+		(fromProtocolBuffer $ getField $ gpgSignedValP p)
+		(fromProtocolBuffer $ getField $ gpgSigP p)
+	fromProtocolBuffer p@(UnSignedP {}) = T.UnSigned
+		(fromProtocolBuffer $ getField $ mkUnSignedP p)
+
+instance ProtocolBuffer GpgSigP T.GpgSig where
+	toProtocolBuffer (T.GpgSig t) = GpgSigP
+		{ mkGpgSigP = putField ( val t) }
+	fromProtocolBuffer p = T.GpgSig $ Val $ getField $ mkGpgSigP p
+
+instance ProtocolBuffer ElapsedTimeP T.ElapsedTime where
+	toProtocolBuffer (T.ElapsedTime t) = ElapsedTimeP
+		{ mkElapsedTimeP = putField t }
+	fromProtocolBuffer p = T.ElapsedTime $ getField $ mkElapsedTimeP p
+
+instance ProtocolBuffer AnyMessageP T.AnyMessage where
+	toProtocolBuffer (T.User t) = UserP
+		{ mkUserP = putField $ toProtocolBuffer t }
+	toProtocolBuffer (T.Developer t) = DeveloperP
+		{ mkDeveloperP = putField $ toProtocolBuffer t }
+	fromProtocolBuffer p@(UserP {}) = T.User $
+		fromProtocolBuffer $ getField $ mkUserP p
+	fromProtocolBuffer p@(DeveloperP {}) = T.Developer $
+		fromProtocolBuffer $ getField $ mkDeveloperP p
+
+instance Encode SeenP
+instance Decode SeenP
+instance Encode EnteredP
+instance Decode EnteredP
+instance Encode ControlP
+instance Decode ControlP
+instance Encode ControlActionP
+instance Decode ControlActionP
+instance Encode HashP
+instance Decode HashP
+instance Encode SignatureP
+instance Decode SignatureP
+instance Encode PublicKeyP
+instance Decode PublicKeyP
+instance Encode GpgSigP
+instance Decode GpgSigP
+instance Encode ElapsedTimeP
+instance Decode ElapsedTimeP
+instance Encode AnyMessageP
+instance Decode AnyMessageP
+instance Encode a => Encode (MessageP a)
+-- This is why UndecidableInstances is needed. The need
+-- for a Monoid instance is an implementation detail of
+-- Data.ProtocolBuffers.
+instance (Monoid (Message a), Generic a, Decode a) => Decode (MessageP a)
+instance Encode a => Encode (ActivityP a)
+instance (Monoid (Message a), Generic a, Decode a) => Decode (ActivityP a)
+instance Encode a => Encode (PerhapsSignedP a)
+instance (Monoid (Message a), Generic a, Decode a) => Decode (PerhapsSignedP a)