diff options
Diffstat (limited to 'ProtocolBuffers.hs')
-rw-r--r-- | ProtocolBuffers.hs | 275 |
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) |