debug-me-1.20170505: ProtocolBuffers.hs

{- Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# 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.
 -
 - Note that the type level numbers used with fields should never be
 - changed.
 -}

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)
	, elapsedTimeP :: Required 7 (Message ElapsedTimeP)
	, activitySignatureP :: Required 8 (Message SignatureP)
	}
	deriving (Generic)

data ControlP = ControlP
	{ controlP :: Required 9 (Message ControlActionP)
	, controlSignatureP ::Required 10 (Message SignatureP)
	}
	deriving (Generic)

data ControlActionP
	= EnteredRejectedP
		{ enteredRejectedP :: Required 11 (Message HashP)
		, enteredLastAcceptedP :: Optional 12 (Message HashP)
		}
	| SessionKeyP
		{ sessionKeyP :: Required 13 (Message (PerhapsSignedP PublicKeyP))
		, protocolVersionP :: Required 14 (Value B.ByteString)
		}
	| SessionKeyAcceptedP
		{ sessionKeyAcceptedP :: Required 15 (Message PublicKeyP) }
	| SessionKeyRejectedP
		{ sessionKeyRejectedP :: Required 16 (Message PublicKeyP) }
	| ChatMessageP
		{ chatMessageSenderName :: Required 17 (Value B.ByteString)
		, chatMessage :: Required 18 (Value B.ByteString)
		}
	deriving (Generic)

data SignatureP
	= Ed25519SignatureP
		{ ed25519SignatureP :: Required 19 (Value B.ByteString) }
	| OtherSignatureP
		{ otherSignatureP :: Required 20 (Value B.ByteString) }
	deriving (Generic)

data PublicKeyP = PublicKeyP 
	{ mkPublicKeyP :: Required 21 (Value B.ByteString) }
	deriving (Generic)

data PerhapsSignedP a
	= GpgSignedP
		{ gpgSignedValP :: Required 22 (Message a)
		, gpgSigP :: Required 23 (Message GpgSigP)
		, gpgKeyExportP :: Required 24 (Message GpgKeyExportP)
		}
	| UnSignedP
		{ mkUnSignedP :: Required 25 (Message a )
		}
	deriving (Generic)

data GpgSigP = GpgSigP
	{ mkGpgSigP :: Required 26 (Value B.ByteString) }
	deriving (Generic)

data GpgKeyExportP = GpgKeyExportP
	{ mkGpgKeyExportP :: Required 27 (Value B.ByteString) }
	deriving (Generic)

data ElapsedTimeP = ElapsedTimeP
	{ mkElapsedTimeP :: Required 28 (Value Double) }
	deriving (Generic)

data AnyMessageP
	= UserP { mkUserP :: Required 29 (Message (MessageP SeenP)) }
	| DeveloperP { mkDeveloperP :: Required 30 (Message (MessageP EnteredP)) }
	deriving (Generic)

data HashP = HashP
	{ hashMethodP :: Required 31 (Message HashMethodP)
	, hashValueP :: Required 32 (Value B.ByteString)
	}
	deriving (Generic)

data HashMethodP
	= SHA512P { mkSHA512P :: Required 33 (Value Bool) }
	| SHA3P { mkSHA3P :: Required 34 (Value Bool) }
	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.prevEntered = 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@(T.EnteredRejected {}) = EnteredRejectedP
		{ enteredRejectedP = putField $ toProtocolBuffer $ T.enteredRejected t
		, enteredLastAcceptedP = putField $ toProtocolBuffer <$> T.enteredLastAccepted t
		}
	toProtocolBuffer (T.SessionKey t v) = SessionKeyP
		{ sessionKeyP = putField $ toProtocolBuffer t
		, protocolVersionP = putField $ val v
		}
	toProtocolBuffer (T.SessionKeyAccepted t) = SessionKeyAcceptedP
		{ sessionKeyAcceptedP = putField $ toProtocolBuffer t }
	toProtocolBuffer (T.SessionKeyRejected t) = SessionKeyRejectedP
		{ sessionKeyRejectedP = putField $ toProtocolBuffer t }
	toProtocolBuffer (T.ChatMessage sendername t) = ChatMessageP
		{ chatMessageSenderName = putField (val sendername)
		, chatMessage = putField (val t)
		}
	fromProtocolBuffer p@(EnteredRejectedP {}) = T.EnteredRejected
		{ T.enteredRejected = fromProtocolBuffer $ getField $ enteredRejectedP p
		, T.enteredLastAccepted = fromProtocolBuffer <$> getField (enteredLastAcceptedP p)
		}
	fromProtocolBuffer p@(SessionKeyP {}) = T.SessionKey
		(fromProtocolBuffer $ getField $ sessionKeyP p)
		(Val $ getField $ protocolVersionP p)
	fromProtocolBuffer p@(SessionKeyAcceptedP {}) = T.SessionKeyAccepted $
		fromProtocolBuffer $ getField $ sessionKeyAcceptedP p
	fromProtocolBuffer p@(SessionKeyRejectedP {}) = T.SessionKeyRejected $
		fromProtocolBuffer $ getField $ sessionKeyRejectedP p
	fromProtocolBuffer p@(ChatMessageP {}) = T.ChatMessage
		(Val $ getField $ chatMessageSenderName p)
		(Val $ getField $ chatMessage 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 HashP T.Hash where
	toProtocolBuffer t = HashP
		{ hashMethodP = putField $ toProtocolBuffer $ T.hashMethod t
		, hashValueP = putField $ val $ T.hashValue t
		}
	fromProtocolBuffer p = T.Hash
		{ T.hashMethod = fromProtocolBuffer $ getField $ hashMethodP p
		, T.hashValue = Val $ getField $ hashValueP p
		}

instance ProtocolBuffer HashMethodP T.HashMethod where
	toProtocolBuffer T.SHA512 = SHA512P { mkSHA512P = putField True }
	toProtocolBuffer T.SHA3 = SHA3P { mkSHA3P = putField True }
	fromProtocolBuffer (SHA512P {}) = T.SHA512
	fromProtocolBuffer (SHA3P {}) = T.SHA3

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 tk)  = GpgSignedP
		{ gpgSignedValP = putField $ toProtocolBuffer tv
		, gpgSigP = putField $ toProtocolBuffer tg
		, gpgKeyExportP = putField $ toProtocolBuffer tk
		}
	toProtocolBuffer (T.UnSigned tv) = UnSignedP
		{ mkUnSignedP = putField $ toProtocolBuffer tv
		}
	fromProtocolBuffer p@(GpgSignedP {}) = T.GpgSigned
		(fromProtocolBuffer $ getField $ gpgSignedValP p)
		(fromProtocolBuffer $ getField $ gpgSigP p)
		(fromProtocolBuffer $ getField $ gpgKeyExportP 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 GpgKeyExportP T.GpgKeyExport where
	toProtocolBuffer (T.GpgKeyExport t) = GpgKeyExportP
		{ mkGpgKeyExportP = putField ( val t) }
	fromProtocolBuffer p = T.GpgKeyExport $ Val $ getField $ mkGpgKeyExportP 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 HashMethodP
instance Decode HashMethodP
instance Encode SignatureP
instance Decode SignatureP
instance Encode PublicKeyP
instance Decode PublicKeyP
instance Encode GpgSigP
instance Decode GpgSigP
instance Encode GpgKeyExportP
instance Decode GpgKeyExportP
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)