diff options
| -rw-r--r-- | Hash.hs | 4 | ||||
| -rw-r--r-- | Types.hs | 54 | ||||
| -rw-r--r-- | Val.hs | 38 | ||||
| -rw-r--r-- | debug-me.cabal | 1 | ||||
| -rw-r--r-- | debug-me.hs | 37 |
5 files changed, 77 insertions, 57 deletions
@@ -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)] @@ -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) @@ -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 |