From 2a271b27c65a286882332b6268e8946851c52f2a Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 14 Apr 2017 09:38:04 -0400
Subject: add JSON serialization

Fairly straightforward, but did have to decide how to encode all the
ByteStrings, since they are not necessarily utf-8. Used base64.

This commit was sponsored by Henrik Riomar on Patreon.
---
 Hash.hs        | 17 +++++++------
 Types.hs       | 79 +++++++++++++++++++++++++++++++++++++++++++++++++---------
 debug-me.cabal |  3 +++
 debug-me.hs    | 16 ++++++------
 4 files changed, 88 insertions(+), 27 deletions(-)

diff --git a/Hash.hs b/Hash.hs
index eca00e4..4174d5f 100644
--- a/Hash.hs
+++ b/Hash.hs
@@ -8,19 +8,22 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C8
 import qualified Crypto.Hash as H
 
--- | Encode a hash pointer using base16 format.
-encodeHashPointer :: HashPointer -> B.ByteString
-encodeHashPointer (HashPointer d) = C8.pack (show d)
-
 class Hashable a where
 	hash :: a -> HashPointer
 
 instance Hashable B.ByteString where
-	hash = HashPointer . H.hash
+	-- Encodes the SHA256 using base16 format
+	hash = HashPointer SHA256 . Val . C8.pack . show . sha256
+
+instance Hashable Val where
+	hash (Val v) = hash v
+
+sha256 :: B.ByteString -> H.Digest H.SHA256
+sha256 = H.hash
 
--- | Hash the concacenation of the hashes, encoding them in base16 format.
+-- | Hash the concacenation of the hashes.
 instance Hashable [HashPointer] where
-	hash = hash . B.concat . map encodeHashPointer
+	hash = hash . B.concat . map (val . hashValue)
 
 instance Hashable a => Hashable (Activity a) where
 	hash (Activity a p s) = hash [hash a, p, hash s]
diff --git a/Types.hs b/Types.hs
index 33df35c..3a04f64 100644
--- a/Types.hs
+++ b/Types.hs
@@ -1,22 +1,35 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, FlexibleInstances, OverloadedStrings #-}
+
 module Types where
 
 import Data.ByteString
-import qualified Crypto.Hash as H
+import GHC.Generics (Generic)
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Codec.Binary.Base64 as B64
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 
 -- | Things that the developer sees.
 data Seen = Seen
-	{ seenData :: ByteString
+	{ seenData :: Val
 	}
-	deriving (Show)
+	deriving (Show, Generic)
+
+instance ToJSON Seen
+instance FromJSON Seen
 
 -- | Things that the developer enters.
 data Entered = Entered
-	{ enteredData :: ByteString
-	, echoData :: ByteString
+	{ enteredData :: Val
+	, echoData :: Val
 	-- ^ Data that is expected to be Seen, but has not been received
 	-- at the time this was entered.
 	}
-	deriving (Show)
+	deriving (Show, Generic)
+
+instance ToJSON Entered
+instance FromJSON Entered
 
 -- | An activity (either Entered or Seen) with a pointer
 -- to the Activity before this one.
@@ -25,15 +38,57 @@ data Entered = Entered
 data Activity a
 	= Activity a HashPointer Signature
 	| StartActivity a Signature
-	deriving (Show)
+	deriving (Show, Generic)
+
+instance ToJSON (Activity Seen)
+instance FromJSON (Activity Seen)
+instance ToJSON (Activity Entered)
+instance FromJSON (Activity Entered)
 
 activityContent :: Activity a -> a
 activityContent (Activity a _ _) = a
 activityContent (StartActivity a _) = a
 
-data Signature = Signature ByteString
-	deriving (Show)
+data Signature = Signature
+	{ signature :: Val
+	}
+	deriving (Show, Generic)
+
+instance ToJSON Signature
+instance FromJSON Signature
+
+-- | A hash pointer to something that hashes to this value.
+data HashPointer = HashPointer
+	{ hashMethod :: HashMethod
+	, hashValue :: Val
+	}
+	deriving (Show, Generic, Eq)
+
+instance ToJSON HashPointer
+instance FromJSON HashPointer
+
+data HashMethod = SHA256
+	deriving (Show, Generic, Eq)
+
+instance ToJSON HashMethod
+instance FromJSON HashMethod
+
+-- | Newtype of ByteString so we can have JSON instances without orphans.
+newtype Val = Val { val :: ByteString }
+	deriving (Show, Generic, Eq, Monoid)
+
+-- | JSON instances for Val, using base64 encoding.
+instance ToJSON Val where
+	toJSON (Val b) = object [ "b" .= b64 b ]
+instance FromJSON Val where
+	parseJSON (Object v) = Val <$> (unb64 =<< v .: "b")
+	parseJSON invalid = typeMismatch "ByteString" invalid
+
+b64 :: ByteString -> T.Text
+b64 = T.decodeUtf8 . B64.encode
 
--- | A SHA2 hash pointer to something that hashes to this value.
-newtype HashPointer = HashPointer (H.Digest H.SHA256)
-	deriving (Show, Eq)
+unb64 :: Monad m => T.Text -> m ByteString
+unb64 t = either
+	(\_ -> fail "bad base64 data")
+	return
+	( B64.decode $ T.encodeUtf8 t)
diff --git a/debug-me.cabal b/debug-me.cabal
index 88e36ac..6f84afb 100644
--- a/debug-me.cabal
+++ b/debug-me.cabal
@@ -31,6 +31,9 @@ Executable debug-me
     , stm (>= 2.4)
     , posix-pty (>= 0.2.1)
     , terminal-size (>= 0.3)
+    , aeson (>= 0.11 && < 1.1)
+    , sandi (>= 0.4)
+    , text (>= 1.2)
   Other-Modules:
     Hash
     Pty
diff --git a/debug-me.hs b/debug-me.hs
index 44f3a38..86558bc 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -41,7 +41,7 @@ developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
 developer ichan ochan = do
 	startact <- atomically $ readTChan ochan
 	case startact of
-		StartActivity (Seen b) sig -> do
+		StartActivity (Seen (Val b)) sig -> do
 			B.hPut stdout b
 			hFlush stdout	
 		_ -> return ()
@@ -69,8 +69,8 @@ sendTtyInput ichan devstate = go
 		atomically $ do
 			ds <- readTVar devstate
 			let entered = Entered
-				{ enteredData = b
-				, echoData = sentSince ds
+				{ enteredData = Val b
+				, echoData = Val (sentSince ds)
 				}
 			let act = Activity entered (lastSeen ds) dummySignature
 			writeTChan ichan act
@@ -91,7 +91,7 @@ sendTtyOutput ochan devstate = go
 		act <- readTChan ochan
 		ds <- readTVar devstate
 		case act of
-			Activity (Seen b) hp sig
+			Activity (Seen (Val b)) hp sig
 				| hp == lastSeen ds -> do
 					let ss = sentSince ds
 					let ss' = if b `B.isPrefixOf` ss
@@ -109,7 +109,7 @@ sendTtyOutput ochan devstate = go
 
 user :: B.ByteString -> Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
 user startmsg p ichan ochan = do
-	let startact = StartActivity (Seen (startmsg <> "\r\n")) dummySignature
+	let startact = StartActivity (Seen (Val (startmsg <> "\r\n"))) dummySignature
 	atomically $ writeTChan ochan startact
 	backlog <- newTVarIO $ Backlog ((hash startact, startact) :| [])
 	_ <- sendPtyOutput p ochan backlog
@@ -128,7 +128,7 @@ sendPtyOutput p ochan backlog = go
 		b <- readPty p
 		atomically $ do
 			Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog
-			let seen = Seen b
+			let seen = Seen (Val b)
 			let act = Activity seen prevhash dummySignature
 			writeTChan ochan act
 			writeTVar backlog (Backlog ((hash act, act) :| toList bl))
@@ -154,7 +154,7 @@ sendPtyInput ichan p backlog = go
 				else do
 					return (Left ("illegal entry" :: String, newact, bl'))
 		case mb of
-			Right b -> do
+			Right (Val b) -> do
 				writePty p b
 				go
 			Left _e -> do
@@ -189,7 +189,7 @@ truncateBacklog (Backlog bl) _ = Backlog bl
 isLegal :: Activity Entered -> Backlog -> Bool
 isLegal (Activity entered hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl))
 	| lastseenhash == hp = True
-	| B.null (echoData entered) = False -- optimisation
+	| B.null (val (echoData entered)) = False -- optimisation
 	| any (== hp) (map fst bl) =
 		let sincehp = reverse (lastseen : takeWhile (\(h, _) -> h /= hp) bl)
 		in echoData entered == mconcat (map (seenData . activityContent . snd) sincehp)
-- 
cgit v1.2.3