summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Hash.hs8
-rw-r--r--PrevActivity.hs43
-rw-r--r--ProtocolBuffers.hs30
-rw-r--r--Role/Developer.hs71
-rw-r--r--Role/Downloader.hs8
-rw-r--r--Role/User.hs20
-rw-r--r--Role/Watcher.hs8
-rw-r--r--Server.hs15
-rw-r--r--TODO6
-rw-r--r--Types.hs8
-rw-r--r--WebSockets.hs25
-rw-r--r--debug-me.cabal1
-rw-r--r--protocol.txt7
13 files changed, 165 insertions, 85 deletions
diff --git a/Hash.hs b/Hash.hs
index 3bfb5a2..3cc8d94 100644
--- a/Hash.hs
+++ b/Hash.hs
@@ -12,8 +12,8 @@ class Hashable a where
hash :: a -> Hash
instance Hashable B.ByteString where
- -- Encodes the SHA256 using base16 format
- hash = Hash SHA256 . Val . C8.pack . show . sha256
+ -- Encodes the SHA512 using base16 format
+ hash = Hash SHA512 . Val . C8.pack . show . sha512
instance Hashable Val where
hash (Val v) = hash v
@@ -21,8 +21,8 @@ instance Hashable Val where
instance Hashable Hash where
hash = id
-sha256 :: B.ByteString -> H.Digest H.SHA256
-sha256 = H.hash
+sha512 :: B.ByteString -> H.Digest H.SHA512
+sha512 = H.hash
-- | A value tagged with a ByteString describing the type of value.
-- This is hashed by hashing the concacenation of the hash of the
diff --git a/PrevActivity.hs b/PrevActivity.hs
new file mode 100644
index 0000000..32e647d
--- /dev/null
+++ b/PrevActivity.hs
@@ -0,0 +1,43 @@
+module PrevActivity where
+
+import Types
+import Crypto
+
+import Control.Concurrent.STM
+
+-- | Remove the prevActivity from a message. Doing this before sending
+-- it over the wire saves transmitting that data, without weakening
+-- security at all.
+removePrevActivityHash :: AnyMessage -> AnyMessage
+removePrevActivityHash msg = case msg of
+ User (ActivityMessage a) -> User (go a)
+ Developer (ActivityMessage a) -> Developer (go a)
+ _ -> msg
+ where
+ go a = ActivityMessage $ a { prevActivity = Nothing }
+
+type RecentActivity = STM (SigVerifier, [Hash])
+
+noRecentActivity :: RecentActivity
+noRecentActivity = return (mempty, [])
+
+-- | Restore the prevActivity to a message received without one.
+-- This needs a RecentActivity cache, and it tries hashes from that cache
+-- as the prevActivity until it finds one that makes the message's
+-- signature verify.
+restorePrevActivityHash :: RecentActivity -> AnyMessage -> STM AnyMessage
+restorePrevActivityHash ra msg = case msg of
+ User (ActivityMessage act) ->
+ User . ActivityMessage <$> (go act =<< ra)
+ Developer (ActivityMessage act) ->
+ Developer . ActivityMessage <$> (go act =<< ra)
+ User (ControlMessage {}) -> return msg
+ Developer (ControlMessage {}) -> return msg
+
+ where
+ go act (_, []) = return act
+ go act (sigverifier, (h:hs)) = do
+ let act' = act { prevActivity = Just h }
+ if verifySigned sigverifier act'
+ then return act'
+ else go act (sigverifier, hs)
diff --git a/ProtocolBuffers.hs b/ProtocolBuffers.hs
index 6d02096..53dfca0 100644
--- a/ProtocolBuffers.hs
+++ b/ProtocolBuffers.hs
@@ -40,7 +40,9 @@ data MessageP a
data ActivityP a = ActivityP
{ activityP :: Required 6 (Message a)
- , prevAtivityP :: Optional 7 (Message HashP)
+ -- This is not included, because the hash is never actually sent
+ -- over the wire!
+ -- , prevAtivityP :: Optional 7 (Message HashP)
, elapsedTimeP :: Required 8 (Message ElapsedTimeP)
, activitySignatureP :: Required 9 (Message SignatureP)
}
@@ -63,12 +65,6 @@ data ControlActionP
{ 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) }
@@ -141,13 +137,12 @@ instance ProtocolBuffer (ActivityP p) (T.Activity t) => ProtocolBuffer (MessageP
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.prevActivity = Nothing -- not sent over the wire
, T.elapsedTime = fromProtocolBuffer $ getField $ elapsedTimeP p
, T.activitySignature = fromProtocolBuffer $ getField $ activitySignatureP p
}
@@ -180,21 +175,6 @@ instance ProtocolBuffer ControlActionP T.ControlAction where
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 }
@@ -252,8 +232,6 @@ 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
diff --git a/Role/Developer.hs b/Role/Developer.hs
index b0d66a5..9e1f40e 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -1,6 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
-module Role.Developer where
+module Role.Developer (
+ run,
+ run',
+ processSessionStart,
+ getServerMessage,
+ Output(..),
+ emitOutput,
+ DeveloperState,
+) where
import Types
import Hash
@@ -10,6 +18,7 @@ import CmdLine
import WebSockets
import SessionID
import Pty
+import PrevActivity
import Control.Concurrent.Async
import Control.Concurrent.STM
@@ -20,20 +29,25 @@ import qualified Data.Text as T
import Data.List
import Data.Maybe
import Control.Monad
+import Data.Monoid
import Data.Time.Clock.POSIX
run :: DeveloperOpts -> IO ()
run = run' developer . debugUrl
-run' :: (TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> UrlString -> IO ()
-run' runner url = void $ runClientApp app
- where
- connect = ConnectMode (T.pack url)
- app = clientApp connect Developer Just runner
+run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> UrlString -> IO ()
+run' runner url = do
+ app <- do
+ let connect = ConnectMode (T.pack url)
+ dsv <- newEmptyTMVarIO
+ let recentactivity = developerStateRecentActivity dsv
+ return $ clientApp connect recentactivity Developer Just $
+ runner dsv
+ void $ runClientApp app
-developer :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
-developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do
- (devstate, startoutput) <- processSessionStart ochan logger
+developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
+developer dsv ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do
+ (devstate, startoutput) <- processSessionStart ochan logger dsv
emitOutput startoutput
ok <- authUser ichan ochan devstate logger
if ok
@@ -63,6 +77,16 @@ data DeveloperState = DeveloperState
-- ^ Used to verify signatures on messages from other developers.
}
+-- | RecentActivity that uses the DeveloperState.
+developerStateRecentActivity :: TMVar (TVar DeveloperState) -> RecentActivity
+developerStateRecentActivity dsv = go =<< tryReadTMVar dsv
+ where
+ go Nothing = noRecentActivity
+ go (Just ds) = do
+ st <- readTVar ds
+ let hs = lastSeen st : enteredSince st ++ fromOtherDevelopersSince st
+ return (userSigVerifier st <> developerSigVerifier st, hs)
+
-- | Read things typed by the developer, and forward them to the TMChan.
sendTtyInput :: TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO ()
sendTtyInput ichan devstate logger = go
@@ -287,8 +311,8 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts
-- | Start by reading the initial two messages from the user,
-- their session key and the startup message.
-processSessionStart :: TMChan AnyMessage -> Logger -> IO (TVar DeveloperState, Output)
-processSessionStart ochan logger = do
+processSessionStart :: TMChan AnyMessage -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output)
+processSessionStart ochan logger dsv = do
sessionmsg <- fromMaybe (error "Did not get session initialization message")
<$> atomically (readTMChan ochan)
logger sessionmsg
@@ -302,25 +326,30 @@ processSessionStart ochan logger = do
then return sv
else error "Badly signed session initialization message"
_ -> error $ "Unexpected session initialization message: " ++ show sessionmsg
- startmsg <- fromMaybe (error "Did not get session startup message")
- <$> atomically (readTMChan ochan)
- logger startmsg
- let (starthash, output) = case startmsg of
- User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _))
- | verifySigned sigverifier act ->
- (hash act, TtyOutput b)
- _ -> error $ "Unexpected startup message: " ++ show startmsg
sk <- genMySessionKey
ts <- getPOSIXTime
st <- newTVarIO $ DeveloperState
- { lastSeen = starthash
+ { lastSeen = hash ()
, sentSince = mempty
, enteredSince = mempty
- , lastActivity = starthash
+ , lastActivity = hash ()
, lastActivityTs = ts
, fromOtherDevelopersSince = mempty
, developerSessionKey = sk
, userSigVerifier = sigverifier
, developerSigVerifier = mempty
}
+ atomically $ putTMVar dsv st
+ startmsg <- fromMaybe (error "Did not get session startup message")
+ <$> atomically (readTMChan ochan)
+ logger startmsg
+ let (starthash, output) = case startmsg of
+ User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _))
+ | verifySigned sigverifier act ->
+ (hash act, TtyOutput b)
+ _ -> error $ "Unexpected startup message: " ++ show startmsg
+ atomically $ modifyTVar' st $ \ds -> ds
+ { lastSeen = starthash
+ , lastActivity = starthash
+ }
return (st, output)
diff --git a/Role/Downloader.hs b/Role/Downloader.hs
index d49b4ec..4d5f6cc 100644
--- a/Role/Downloader.hs
+++ b/Role/Downloader.hs
@@ -4,7 +4,7 @@ import Types
import Log
import CmdLine
import SessionID
-import Role.Developer (run', processSessionStart, getServerMessage, Output(..))
+import Role.Developer
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
@@ -13,13 +13,13 @@ import Data.Time.Clock.POSIX
run :: DownloadOpts -> IO ()
run = run' downloader . downloadUrl
-downloader :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
-downloader _ichan ochan sid = do
+downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
+downloader dsv _ichan ochan sid = do
let logfile = sessionLogFile "." sid
putStrLn $ "Starting download to " ++ logfile
putStrLn "(Will keep downloading until the debug-me session is done.)"
withLogger logfile $ \logger -> do
- (st, _startoutput) <- processSessionStart ochan logger
+ (st, _startoutput) <- processSessionStart ochan logger dsv
go logger st
where
go logger st = do
diff --git a/Role/User.hs b/Role/User.hs
index e0599a8..fe679a5 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -11,6 +11,7 @@ import Crypto
import CmdLine
import WebSockets
import SessionID
+import PrevActivity
import Control.Concurrent.Async
import Control.Concurrent.STM
@@ -31,17 +32,20 @@ run os = fromMaybe (ExitFailure 101) <$> connect
connect = do
putStr "Connecting to debug-me server..."
hFlush stdout
- runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ochan ichan sid -> do
+ usv <- newEmptyTMVarIO
+ let recentactivity = userStateRecentActivity usv
+ runClientApp $ clientApp (InitMode mempty) recentactivity User developerMessages $ \ochan ichan sid -> do
let url = sessionIDUrl sid "localhost" 8081
putStrLn ""
putStrLn "Others can connect to this session and help you debug by running:"
putStrLn $ " debug-me --debug " ++ url
hFlush stdout
- withLogger "debug-me.log" $ go ochan ichan
- go ochan ichan logger = do
+ withLogger "debug-me.log" $ go ochan ichan usv
+ go ochan ichan usv logger = do
(cmd, cmdparams) <- shellCommand os
runWithPty cmd cmdparams $ \(p, ph) -> do
us <- startProtocol startSession ochan logger
+ atomically $ putTMVar usv us
p1 <- async $ sendPtyOutput p ochan us logger
p2 <- async $ sendPtyInput ichan ochan p us logger
`race` forwardTtyInputToPty p
@@ -73,6 +77,16 @@ data UserState = UserState
, lastSeenTs :: POSIXTime
}
+-- | RecentActivity that uses the UserState.
+userStateRecentActivity :: TMVar (TVar UserState) -> RecentActivity
+userStateRecentActivity usv = go =<< tryReadTMVar usv
+ where
+ go Nothing = noRecentActivity
+ go (Just us) = do
+ st <- readTVar us
+ let hs = mapMaybe loggedHash $ toList $ backLog st
+ return (sigVerifier st, hs)
+
-- | Start by establishing our session key, and displaying the starttxt.
startProtocol :: B.ByteString -> TMChan (Message Seen) -> Logger -> IO (TVar UserState)
startProtocol starttxt ochan logger = do
diff --git a/Role/Watcher.hs b/Role/Watcher.hs
index 8bcc91c..a4328f8 100644
--- a/Role/Watcher.hs
+++ b/Role/Watcher.hs
@@ -5,7 +5,7 @@ import Log
import Pty
import CmdLine
import SessionID
-import Role.Developer (run', processSessionStart, getServerMessage, emitOutput)
+import Role.Developer
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
@@ -14,9 +14,9 @@ import Data.Time.Clock.POSIX
run :: WatchOpts -> IO ()
run = run' watcher . watchUrl
-watcher :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
-watcher _ichan ochan _ = inRawMode $ do
- (st, startoutput) <- processSessionStart ochan nullLogger
+watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()
+watcher dsv _ichan ochan _ = inRawMode $ do
+ (st, startoutput) <- processSessionStart ochan nullLogger dsv
emitOutput startoutput
go st
where
diff --git a/Server.hs b/Server.hs
index 62d0a3c..f8e8588 100644
--- a/Server.hs
+++ b/Server.hs
@@ -7,6 +7,7 @@ import CmdLine
import WebSockets
import SessionID
import Log
+import PrevActivity
import Network.Wai
import Network.Wai.Handler.Warp
@@ -144,7 +145,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do
-- (The user is allowed to send Developer messages too.. perhaps
-- they got them from a developer connected to them some other
-- way.)
- relayfromuser session = relayFromSocket conn $ \msg -> do
+ relayfromuser session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do
l <- mkLog msg <$> getPOSIXTime
writeSession session l
@@ -183,11 +184,13 @@ developer o ssv sid conn = bracket setup cleanup go
-- Relay all Developer amessages from the developer's websocket
-- to the broadcast channel.
- relayfromdeveloper session = relayFromSocket conn $ \msg -> case msg of
- Developer _ -> do
- l <- mkLog msg <$> getPOSIXTime
- writeSession session l
- User _ -> return () -- developer cannot send User messages
+ relayfromdeveloper session = relayFromSocket conn noRecentActivity (return ())
+ $ \msg -> case msg of
+ Developer _ -> do
+ l <- mkLog msg <$> getPOSIXTime
+ writeSession session l
+ -- developer cannot send User messages
+ User _ -> return ()
-- Relay user messages from the developer's clone of the
-- broadcast channel to the developer's websocket.
diff --git a/TODO b/TODO
index 0d98317..5a070da 100644
--- a/TODO
+++ b/TODO
@@ -21,12 +21,6 @@
multiple developers, as each time a developer gets an Activity Seen,
they can update their state to use the Activity Entered that it points
to.
-* Leave the prevMessage out of Activity serialization to save BW.
- Do include it in the data that gets signed, so it can be recovered
- by trying each likely (recently seen) Activity as the prevMessage, and
- checking the signature.
- (If doing this, might as well switch to SHA512, since hash size does not
- matter.)
* loadLog should verify the hashes (and signatures) in the log, and
refuse to use logs that are not valid proofs of a session.
(--replay and --graphvis need this; server's use of loadLog does not)
diff --git a/Types.hs b/Types.hs
index 18b197e..1335cdc 100644
--- a/Types.hs
+++ b/Types.hs
@@ -55,7 +55,7 @@ instance DataSize a => DataSize (Message a) where
--
-- The Signature is over both the data in the activity, and its pointer.
--
--- Note that the Signature is included in the Hash of an Activity,
+-- The Signature is included in the Hash of an Activity,
-- which is why it's part of the Activity.
data Activity a = Activity
{ activity :: a
@@ -107,12 +107,12 @@ data Hash = Hash
deriving (Show, Generic, Eq)
instance DataSize Hash where
- dataSize (Hash { hashMethod = SHA256 }) = 64
+ dataSize (Hash { hashMethod = SHA512 }) = 128
dataSize (Hash { hashMethod = SHA3 }) = 56
--- | We use SHA256. (SHA3 is included to future proof, and because it
+-- | We use SHA512. (SHA3 is included to future proof, and because it
-- improves the generated JSON.)
-data HashMethod = SHA256 | SHA3
+data HashMethod = SHA512 | SHA3
deriving (Show, Generic, Eq)
data Signature
diff --git a/WebSockets.hs b/WebSockets.hs
index f159271..00f762a 100644
--- a/WebSockets.hs
+++ b/WebSockets.hs
@@ -18,6 +18,7 @@ module WebSockets (
import Types
import SessionID
import ProtocolBuffers
+import PrevActivity
import Network.WebSockets hiding (Message)
import Control.Concurrent.STM
@@ -62,11 +63,12 @@ runClientApp app = do
-- | Make a client that sends and receives AnyMessages over a websocket.
clientApp
:: Mode
+ -> RecentActivity
-> (sent -> AnyMessage)
-> (AnyMessage -> Maybe received)
-> (TMChan sent -> TMChan received -> SessionID -> IO a)
-> ClientApp a
-clientApp mode mksent filterreceived a conn = do
+clientApp mode recentactivity mksent filterreceived a conn = do
-- Ping every 30 seconds to avoid timeouts caused by proxies etc.
forkPingThread conn 30
_v <- negotiateWireVersion conn
@@ -83,7 +85,7 @@ clientApp mode mksent filterreceived a conn = do
sthread <- async $ relayToSocket conn mksent $
atomically (readTMChan schan)
rthread <- async $ do
- relayFromSocket conn $ \v -> do
+ relayFromSocket conn recentactivity (waitTillDrained rchan) $ \v -> do
case filterreceived v of
Nothing -> return ()
Just r -> atomically $ writeTMChan rchan r
@@ -101,14 +103,24 @@ clientApp mode mksent filterreceived a conn = do
void $ waitCatch rthread
go sid (schan, rchan, _, _) = a schan rchan sid
-relayFromSocket :: Connection -> (AnyMessage -> IO ()) -> IO ()
-relayFromSocket conn sender = go
+waitTillDrained :: TMChan a -> IO ()
+waitTillDrained c = atomically $ do
+ e <- isEmptyTMChan c
+ if e
+ then return ()
+ else retry
+
+relayFromSocket :: Connection -> RecentActivity -> IO () -> (AnyMessage -> IO ()) -> IO ()
+relayFromSocket conn recentactivity waitprevprocessed sender = go
where
go = do
r <- receiveData conn
case r of
AnyMessage msg -> do
- sender msg
+ waitprevprocessed
+ msg' <- atomically $
+ restorePrevActivityHash recentactivity msg
+ sender msg'
go
Done -> return ()
WireProtocolError e -> protocolError conn e
@@ -122,7 +134,8 @@ relayToSocket conn mksent getter = go
case mmsg of
Nothing -> return ()
Just msg -> do
- sendBinaryData conn $ AnyMessage $ mksent msg
+ sendBinaryData conn $ AnyMessage $
+ removePrevActivityHash $ mksent msg
go
-- | Framing protocol used over a websocket connection.
diff --git a/debug-me.cabal b/debug-me.cabal
index 70ea2ac..48d391a 100644
--- a/debug-me.cabal
+++ b/debug-me.cabal
@@ -61,6 +61,7 @@ Executable debug-me
Log
Memory
Pty
+ PrevActivity
ProtocolBuffers
Replay
Role.Developer
diff --git a/protocol.txt b/protocol.txt
index 25f239d..d290be7 100644
--- a/protocol.txt
+++ b/protocol.txt
@@ -21,7 +21,7 @@ Activity Seen and Activity Entered messages have a prevActivity,
which points to the Hash of a previous Activity. (And is Nothing for the
first Activity Seen.) So a chain of messages is built up.
-(The exact details about how these objects are hashed is not described here;
+(The exact details about how objects are hashed is not described here;
see Hash.hs for the implementation. Note that the JSON strings are *not*
directly hashed (to avoid tying hashing to JSON serialization details),
instead the values in the data types are hashed.)
@@ -88,3 +88,8 @@ before it, etc.
Note that there could be multiple developers, in which case each will
send their session key before being able to do anything except observe
the debug-me session.
+
+The prevActivity hash is actually not included in the data sent across the
+wire. It's left out to save space, and gets added back in by the receiver.
+The receiver uses the signature of the message to tell when it's found
+the right prevActivity hash to add back in.
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-10 04:05:04 +0000