path: root/ProtocolBuffers.hs

{-# 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)
	-- This is not included, because the hash is never actually sent
	-- over the wire!
	-- , 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 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
		, elapsedTimeP = putField $ toProtocolBuffer $ T.elapsedTime t
		, activitySignatureP = putField $ toProtocolBuffer $ T.activitySignature t
		}
	fromProtocolBuffer p = T.Activity
		{ T.activity = fromProtocolBuffer $ getField $ activityP p
		, T.prevActivity = Nothing -- not sent over the wire
		, 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 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 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)