{- Copyright 2017 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE DeriveGeneric, DataKinds, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} {-# LANGUAGE OverloadedStrings, MonoLocalBinds #-} {- | 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. -- MonoLocalBinds is also used to avoid a ghc warning. 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)