From f7999cecc2bb0c76d88005444478e8500c624786 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Apr 2017 20:07:47 -0400 Subject: fully working signatures This commit was sponsored by Ethan Aubin. --- debug-me.hs | 289 ++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 204 insertions(+), 85 deletions(-) (limited to 'debug-me.hs') diff --git a/debug-me.hs b/debug-me.hs index e16576b..dc50b1c 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -50,36 +50,58 @@ test = do return exitstatus networkDelay :: IO () -networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit --- networkDelay = threadDelay 150000 -- 150 ms ; transatlantic latency +-- networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit +networkDelay = threadDelay 150000 -- 150 ms ; transatlantic latency developer :: TChan (Message Entered) -> TChan (Message Seen) -> IO () developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do + -- Start by reading the initial two messages from the user side, + -- their session key and the startup message. + sessionmsg <- atomically $ readTChan ochan + logger $ User sessionmsg + sigverifier <- case sessionmsg of + ControlMessage c@(Control (SessionKey pk) _) -> + let sv = mkSigVerifier pk + in if verifySigned sv c + then return sv + else protocolError "Badly signed session initialization message" + _ -> protocolError $ "Unexpected session initialization message: " ++ show sessionmsg startmsg <- atomically $ readTChan ochan logger $ User startmsg starthash <- case startmsg of - ActivityMessage act@(Activity (Seen (Val b)) Nothing sig) -> do - B.hPut stdout b - hFlush stdout - return (hash act) - _ -> protocolError $ "Unexpected startup: " ++ show startmsg + ActivityMessage act@(Activity (Seen (Val b)) Nothing _) + | verifySigned sigverifier act -> do + B.hPut stdout b + hFlush stdout + return (hash act) + _ -> protocolError $ "Unexpected startup message: " ++ show startmsg + + sk <- genMySessionKey devstate <- newTVarIO $ DeveloperState { lastSeen = starthash , sentSince = mempty , enteredSince = mempty , lastActivity = starthash + , developerSessionKey = sk + , developerSigVerifier = sigverifier } - _ <- sendTtyInput ichan devstate logger - `concurrently` sendTtyOutput ochan devstate logger - return () + ok <- authUser ichan ochan devstate logger + if ok + then do + _ <- sendTtyInput ichan devstate logger + `concurrently` sendTtyOutput ochan devstate logger + return () + else do + hPutStrLn stderr "\nUser did not grant access to their terminal." data DeveloperState = DeveloperState { lastSeen :: Hash , sentSince :: [B.ByteString] , enteredSince :: [Hash] , lastActivity :: Hash + , developerSessionKey :: MySessionKey + , developerSigVerifier :: SigVerifier } - deriving (Show) -- | Read things typed by the developer, and forward them to the TChan. sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () @@ -102,7 +124,8 @@ sendTtyInput ichan devstate logger = go { enteredData = Val b , echoData = Val ed } - let act = Activity entered (Just $ lastActivity ds) dummySignature + let act = mkSigned (developerSessionKey ds) $ + Activity entered (Just $ lastActivity ds) writeTChan ichan (ActivityMessage act) let acth = hash act let ds' = ds @@ -120,55 +143,96 @@ sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO () sendTtyOutput ochan devstate logger = go where go = do - (v, msg) <- atomically $ processOutput ochan devstate + (o, msg) <- atomically $ getUserMessage ochan devstate logger $ User msg - case v of - ProtocolError e -> protocolError e - TtyOutput b -> do - B.hPut stdout b - hFlush stdout - go - Beep -> do - B.hPut stdout "\a" - hFlush stdout - go - NoOutput -> go + emitOutput o + go + +-- | Present our session key to the user. +-- Wait for them to accept or reject it, while displaying any Seen data +-- in the meantime. +authUser :: TChan (Message Entered) -> TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool +authUser ichan ochan devstate logger = do + ds <- atomically $ readTVar devstate + pk <- myPublicKey (developerSessionKey ds) + let msg = ControlMessage $ mkSigned (developerSessionKey ds) + (Control (SessionKey pk)) + atomically $ writeTChan ichan msg + logger $ Developer msg + waitresp pk + where + waitresp pk = do + (o, msg) <- atomically $ getUserMessage ochan devstate + logger $ User msg + emitOutput o + case o of + GotControl (SessionKeyAccepted pk') + | pk' == pk -> return True + GotControl (SessionKeyRejected pk') + | pk' == pk -> return False + _ -> waitresp pk -data Output = TtyOutput B.ByteString | Beep | ProtocolError String | NoOutput +data Output + = TtyOutput B.ByteString + | Beep + | ProtocolError String + | GotControl ControlAction -processOutput :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen) -processOutput ochan devstate = do +emitOutput :: Output -> IO () +emitOutput (ProtocolError e) = + protocolError e +emitOutput (TtyOutput b) = do + B.hPut stdout b + hFlush stdout +emitOutput Beep = do + B.hPut stdout "\a" + hFlush stdout +emitOutput (GotControl _) = + return () + +-- | Get messages from user, check their signature, and make sure that they +-- are properly chained from past messages, before returning. +getUserMessage :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen) +getUserMessage ochan devstate = do msg <- readTChan ochan ds <- readTVar devstate - -- TODO check sig before doing anything else - o <- case msg of - ActivityMessage act@(Activity (Seen (Val b)) _ _) -> do - let (legal, ds') = isLegalSeen act ds - if legal - then do - writeTVar devstate ds' - return (TtyOutput b) - else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act) ++ "\n" ++ show ds) - ControlMessage (Control c _) -> case c of - Rejected _ -> do - -- When they rejected a message we sent, - -- anything we sent subsequently will - -- also be rejected, so forget about it. - let ds' = ds - { sentSince = mempty - , enteredSince = mempty - } + -- Check signature before doing anything else. + if verifySigned (developerSigVerifier ds) msg + then do + o <- process ds msg + return (o, msg) + else getUserMessage ochan devstate + where + process ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do + let (legal, ds') = isLegalSeen act ds + if legal + then do writeTVar devstate ds' - return Beep - SessionKey _ -> return NoOutput - SessionKeyAccepted _ -> return NoOutput - SessionKeyRejected _ -> return NoOutput - return (o, msg) + return (TtyOutput b) + else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act)) + process ds (ControlMessage (Control (Rejected _) _)) = do + -- When they rejected a message we sent, + -- anything we sent subsequently will + -- also be rejected, so forget about it. + let ds' = ds + { sentSince = mempty + , enteredSince = mempty + } + writeTVar devstate ds' + return Beep + process _ (ControlMessage (Control c@(SessionKey _) _)) = + return (GotControl c) + process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = + return (GotControl c) + process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = + return (GotControl c) -- | Check if the Seen activity is legal, forming a chain with previous -- ones, and returns an updated DeveloperState. +-- +-- Does not check the signature. isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState) -isLegalSeen act@(Activity (Seen (Val b)) (Just hp) sig) ds +isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds -- Does it chain to the last Seen activity? | hp == lastSeen ds = -- Trim sentSince and enteredSince to @@ -179,7 +243,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) sig) ds (ss', es') = if b `B.isPrefixOf` mconcat ss then (drop n ss, drop n es) else (mempty, mempty) - in yes $ DeveloperState + in yes ds { lastSeen = acth , sentSince = ss' , enteredSince = es' @@ -197,7 +261,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) sig) ds es = enteredSince ds ss' = drop (i+1) ss es' = drop (i+1) es - in yes $ DeveloperState + in yes ds { lastSeen = acth , sentSince = ss' , enteredSince = es' @@ -210,25 +274,36 @@ isLegalSeen (Activity _ Nothing _) ds = (False, ds) user :: B.ByteString -> Pty -> TChan (Message Entered) -> TChan (Message Seen) -> IO () user starttxt p ichan ochan = withLogger "debug-me.log" $ \logger -> do - let act = Activity (Seen (Val (starttxt <> "\r\n"))) Nothing dummySignature + -- Start by establishing our session key, and displaying the starttxt. + let initialmessage msg = do + atomically $ writeTChan ochan msg + logger $ User msg + sk <- genMySessionKey + pk <- myPublicKey sk + let c = mkSigned sk $ Control (SessionKey pk) + initialmessage $ ControlMessage c + let act = mkSigned sk $ Activity (Seen (Val (starttxt <> "\r\n"))) Nothing let startmsg = ActivityMessage act - logger $ User startmsg + initialmessage startmsg l <- mkLog (User startmsg) <$> getPOSIXTime - atomically $ writeTChan ochan startmsg us <- newTVarIO $ UserState { backLog = l :| [] + , userSessionKey = sk + , userSigVerifier = mempty } _ <- sendPtyOutput p ochan us logger `concurrently` sendPtyInput ichan ochan p us logger return () + where -- | Log of recent Activity, with the most recent first. type Backlog = NonEmpty Log data UserState = UserState { backLog :: Backlog + , userSessionKey :: MySessionKey + , userSigVerifier :: SigVerifier } - deriving (Show) -- | Forward things written to the Pty out the TChan. sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO () @@ -250,16 +325,19 @@ instance SendableToDeveloper Seen where sendDeveloper ochan us seen now = do st <- readTVar us let bl@(prev :| _) = backLog st - let msg = ActivityMessage $ - Activity seen (loggedHash prev) dummySignature + let msg = ActivityMessage $ + mkSigned (userSessionKey st) $ + Activity seen (loggedHash prev) let l = mkLog (User msg) now writeTChan ochan msg writeTVar us $ st { backLog = l :| toList bl } return msg instance SendableToDeveloper ControlAction where - sendDeveloper ochan _us c _now = do - let msg = ControlMessage $ Control c dummySignature + sendDeveloper ochan us c _now = do + st <- readTVar us + let msg = ControlMessage $ + mkSigned (userSessionKey st) (Control c) -- Control messages are not kept in the backlog. writeTChan ochan msg return msg @@ -272,39 +350,78 @@ sendPtyInput ichan ochan p us logger = go go = do networkDelay now <- getPOSIXTime - v <- atomically $ do - msg <- readTChan ichan - st <- readTVar us - -- TODO check signature first - case msg of + v <- atomically $ getDeveloperMessage ichan ochan us now + case v of + InputMessage (ActivityMessage entered) -> do + logger $ Developer $ ActivityMessage entered + writePty p $ val $ enteredData $ activity entered + go + InputMessage (ControlMessage (Control c _)) -> case c of + SessionKey pk -> do + checkDeveloperPublicKey ochan us logger pk + go + Rejected r -> protocolError $ "User side received a Rejected: " ++ show r + SessionKeyAccepted _ -> protocolError "User side received a SessionKeyAccepted" + SessionKeyRejected _ -> protocolError "User side received a SessionKeyRejected" + RejectedMessage rej -> do + logger $ User rej + go + BadlySignedMessage _ -> go + +data Input + = InputMessage (Message Entered) + | RejectedMessage (Message Seen) + | BadlySignedMessage (Message Entered) + +-- Get message from developer, verify its signature is from a developer we +-- have allowed (unless it's a SessionKey control message, then the +-- signature of the message is only verified against the key in it), and +-- make sure it's legal before returning it. If it's not legal, sends a +-- Reject message. +getDeveloperMessage :: TChan (Message Entered) -> TChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input +getDeveloperMessage ichan ochan us now = do + msg <- readTChan ichan + st <- readTVar us + case msg of + ControlMessage (Control (SessionKey pk) _) -> do + let sigverifier = mkSigVerifier pk + if verifySigned sigverifier msg + then return (InputMessage msg) + else return (BadlySignedMessage msg) + _ -> if verifySigned (userSigVerifier st) msg + then case msg of ActivityMessage entered -> do - -- Don't need to retain backlog before the Activity - -- that entered references. + -- Don't need to retain backlog + -- before the Activity that entered + -- references. let bl' = reduceBacklog $ truncateBacklog (backLog st) entered if isLegalEntered entered (st { backLog = bl' }) then do let l = mkLog (Developer msg) now writeTVar us (st { backLog = l :| toList bl' }) - return (Right msg) + return (InputMessage msg) else do let reject = Rejected entered - Left <$> sendDeveloper ochan us reject now + RejectedMessage <$> sendDeveloper ochan us reject now ControlMessage (Control _ _) -> - return (Right msg) - case v of - Right (ActivityMessage entered) -> do - logger $ Developer $ ActivityMessage entered - writePty p $ val $ enteredData $ activity entered - go - Right (ControlMessage (Control c _)) -> case c of - Rejected r -> protocolError $ "User side received a Rejected: " ++ show r - SessionKey _ -> protocolError "Adding session keys to running session not supported yet" - SessionKeyAccepted _ -> protocolError "User side received a SessionKeyAccepted" - SessionKeyRejected _ -> protocolError "User side received a SessionKeyRejected" - Left rejact -> do - logger $ User rejact - go + return (InputMessage msg) + else return (BadlySignedMessage msg) + +-- | Check if the public key a developer presented is one we want to use, +-- and if so, add it to the userSigVerifier. +checkDeveloperPublicKey :: TChan (Message Seen) -> TVar UserState -> Logger -> PublicKey -> IO () +checkDeveloperPublicKey ochan us logger pk = do + now <- getPOSIXTime + -- TODO check gpg sig.. + msg <- atomically $ do + st <- readTVar us + let sv = userSigVerifier st + let sv' = sv `mappend` mkSigVerifier pk + let st' = st { userSigVerifier = sv' } + writeTVar us st' + sendDeveloper ochan us (SessionKeyAccepted pk) now + logger $ User msg -- | Truncate the Backlog to remove entries older than the one -- that the Activity Entered refers to, but only if the referred @@ -353,9 +470,11 @@ reduceBacklog (b :| l) = b :| go 0 (take 1000 l) -- -- Activities that do not enter data point to the first message -- sent in the debug-me session. +-- +-- Does not check the signature. isLegalEntered :: Activity Entered -> UserState -> Bool isLegalEntered (Activity _ Nothing _) _ = False -isLegalEntered (Activity a (Just hp) sig) us +isLegalEntered (Activity a (Just hp) _) us | loggedHash lastact == Just hp = True | B.null (val (echoData a)) = False -- optimisation | any (== Just hp) (map loggedHash bl) = -- cgit v1.2.3