switch wire message seralization to use protocol buffers

This way it's not tied to details of the haskell binary library,
and implementations in other languages should be fairly simple to do.

The haskell protobuf library was used because it does not need extra
tooling or build steps. So I didn't write a .proto file, but one could
fairly easily be written by following ProtocolBuffers.hs and translating
it.

ProtocolBuffers.hs is *extremely* repetative and tedious code. Surely
there must be a way to not need to write all of that? Oh well, I wrote
it..

Sizes of serialized messages:

">>> debug-me session started": 121
sending a single key press: 169

This seems equally as efficient as the binary serialization was;
that was 165 bytes before elapsedTime was added.

This commit was sponsored by Ethan Aubin.

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)