diff options
| -rw-r--r-- | Hash.hs | 17 | ||||
| -rw-r--r-- | Types.hs | 79 | ||||
| -rw-r--r-- | debug-me.cabal | 3 | ||||
| -rw-r--r-- | debug-me.hs | 16 |
4 files changed, 88 insertions, 27 deletions
@@ -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] @@ -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) |