From b5d5f86a88c8dbd1cee9e28a659bfe1c26f38eaa Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 14 Apr 2017 10:05:13 -0400 Subject: improve JSON Most of the time, ByteStrings will be able to be encoded as utf8, so avoid base64 when not needed. Adjusted some of the types in order to generate more usual JSON. In particular, removed StartActivity. The JSON now looks like this (with the signature still not populated): {"signature":{"v":""},"prevActivity":{"hashValue":{"v":"3b1abe614dd43bdb2d9a56777884e2d0f3bac9796e2d25c1ad52bb689c117286"},"hashMethod":"SHA256"},"activity":{"echoData":{"v":""},"enteredData":{"v":"l"}}} 203 bytes to send a single keystroke is not great when there's really only 1+64(hash) bytes of unique data. So, may end up adding a wire encoding on top of this. But, JSON is good to have for storage of the proofs, etc. Also, it does compress well. Two such JSON objects gzip -9 to 219 bytes, and three to 265 bytes. So, 37 bytes per keystroke. This is *exactly* as efficient as gzip -9 of $c$hash formatted data. This commit was sponsored by Jack Hill on Patreon. --- Hash.hs | 4 ++-- Types.hs | 54 ++++++++++++++++-------------------------------------- Val.hs | 38 ++++++++++++++++++++++++++++++++++++++ debug-me.cabal | 1 + debug-me.hs | 37 ++++++++++++++++++++----------------- 5 files changed, 77 insertions(+), 57 deletions(-) create mode 100644 Val.hs diff --git a/Hash.hs b/Hash.hs index 4174d5f..f2b8d75 100644 --- a/Hash.hs +++ b/Hash.hs @@ -26,8 +26,8 @@ instance Hashable [HashPointer] where 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] - hash (StartActivity a s) = hash [hash a, hash s] + hash (Activity a (Just p) s) = hash [hash a, p, hash s] + hash (Activity a Nothing s) = hash [hash a, hash s] instance Hashable Entered where hash v = hash [hash (enteredData v), hash (echoData v)] diff --git a/Types.hs b/Types.hs index 3a04f64..d1cb513 100644 --- a/Types.hs +++ b/Types.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric, FlexibleInstances #-} -module Types where +module Types ( + module Types, + Val(..) +) where + +import Val -import Data.ByteString 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 @@ -35,9 +35,11 @@ instance FromJSON Entered -- to the Activity before this one. -- -- The Signature is over both the data in the activity, and its pointer. -data Activity a - = Activity a HashPointer Signature - | StartActivity a Signature +data Activity a = Activity + { activity :: a + , prevActivity :: (Maybe HashPointer) + , signature :: Signature + } deriving (Show, Generic) instance ToJSON (Activity Seen) @@ -45,13 +47,7 @@ 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 - { signature :: Val - } +newtype Signature = Signature Val deriving (Show, Generic) instance ToJSON Signature @@ -67,28 +63,10 @@ data HashPointer = HashPointer instance ToJSON HashPointer instance FromJSON HashPointer -data HashMethod = SHA256 +-- | We use SHA256. (SHA3 is included to future proof, and because it +-- improves the generated JSON.) +data HashMethod = SHA256 | SHA3 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 - -unb64 :: Monad m => T.Text -> m ByteString -unb64 t = either - (\_ -> fail "bad base64 data") - return - ( B64.decode $ T.encodeUtf8 t) diff --git a/Val.hs b/Val.hs new file mode 100644 index 0000000..86a35c9 --- /dev/null +++ b/Val.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, FlexibleInstances, OverloadedStrings #-} + +module Val where + +import Data.ByteString +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 + +-- | 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 when the value +-- is not utf-8 encoded, and otherwise using a more efficient encoding. +instance ToJSON Val where + toJSON (Val b) = case T.decodeUtf8' b of + Right v -> object [ "v" .= v ] + Left _ -> object [ "b64" .= b64 b ] +instance FromJSON Val where + parseJSON (Object o) = do + mv <- o .:? "v" + case mv of + Just v -> return $ Val $ T.encodeUtf8 v + Nothing -> Val <$> (unb64 =<< o .: "b64") + parseJSON invalid = typeMismatch "ByteString" invalid + +b64 :: ByteString -> T.Text +b64 = T.decodeUtf8 . B64.encode + +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 6f84afb..7306d0d 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -38,6 +38,7 @@ Executable debug-me Hash Pty Types + Val source-repository head type: git diff --git a/debug-me.hs b/debug-me.hs index 86558bc..5f0f628 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -13,8 +13,10 @@ import System.IO import System.Process import System.Exit import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Monoid +import Data.Aeson main :: IO () main = do @@ -41,7 +43,7 @@ developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () developer ichan ochan = do startact <- atomically $ readTChan ochan case startact of - StartActivity (Seen (Val b)) sig -> do + Activity (Seen (Val b)) Nothing sig -> do B.hPut stdout b hFlush stdout _ -> return () @@ -72,7 +74,7 @@ sendTtyInput ichan devstate = go { enteredData = Val b , echoData = Val (sentSince ds) } - let act = Activity entered (lastSeen ds) dummySignature + let act = Activity entered (Just $ lastSeen ds) dummySignature writeTChan ichan act let ds' = ds { sentSince = sentSince ds <> b } writeTVar devstate ds' @@ -91,7 +93,7 @@ sendTtyOutput ochan devstate = go act <- readTChan ochan ds <- readTVar devstate case act of - Activity (Seen (Val b)) hp sig + Activity (Seen (Val b)) (Just hp) sig | hp == lastSeen ds -> do let ss = sentSince ds let ss' = if b `B.isPrefixOf` ss @@ -109,7 +111,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 (Val (startmsg <> "\r\n"))) dummySignature + let startact = Activity (Seen (Val (startmsg <> "\r\n"))) Nothing dummySignature atomically $ writeTChan ochan startact backlog <- newTVarIO $ Backlog ((hash startact, startact) :| []) _ <- sendPtyOutput p ochan backlog @@ -129,7 +131,7 @@ sendPtyOutput p ochan backlog = go atomically $ do Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog let seen = Seen (Val b) - let act = Activity seen prevhash dummySignature + let act = Activity seen (Just prevhash) dummySignature writeTChan ochan act writeTVar backlog (Backlog ((hash act, act) :| toList bl)) go @@ -141,7 +143,7 @@ sendPtyInput ichan p backlog = go where go = do networkDelay - mb <- atomically $ do + v <- atomically $ do newact <- readTChan ichan bl <- readTVar backlog -- Don't need to retain backlog before the Activity @@ -150,12 +152,13 @@ sendPtyInput ichan p backlog = go if isLegal newact bl' then do writeTVar backlog bl' - return (Right (enteredData (activityContent newact))) + return (Right newact) else do - return (Left ("illegal entry" :: String, newact, bl')) - case mb of - Right (Val b) -> do - writePty p b + return (Left ("illegal entry" :: String, encode newact, bl')) + case v of + Right entered -> do + L.putStrLn (encode entered) + writePty p (val (enteredData (activity entered))) go Left _e -> do -- print e @@ -168,12 +171,12 @@ sendPtyInput ichan p backlog = go -- done. truncateBacklog :: Backlog -> Activity Entered -> Backlog truncateBacklog (Backlog (b :| l)) (Activity _ hp _) - | fst b == hp = Backlog (b :| []) + | Just (fst b) == hp = Backlog (b :| []) | otherwise = Backlog (b :| go [] l) where go c [] = reverse c go c (x:xs) - | fst x == hp = reverse (x:c) + | Just (fst x) == hp = reverse (x:c) | otherwise = go (x:c) xs truncateBacklog (Backlog bl) _ = Backlog bl @@ -188,11 +191,11 @@ truncateBacklog (Backlog bl) _ = Backlog bl -- Seen activity. isLegal :: Activity Entered -> Backlog -> Bool isLegal (Activity entered hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl)) - | lastseenhash == hp = True + | Just lastseenhash == hp = True | 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) + | any (== hp) (map (Just . fst) bl) = + let sincehp = reverse (lastseen : takeWhile (\(h, _) -> Just h /= hp) bl) + in echoData entered == mconcat (map (seenData . activity . snd) sincehp) | otherwise = False isLegal _ _ = False -- cgit v1.2.3