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. --- Crypto.hs | 75 ++++++++++++---- Hash.hs | 6 ++ TODO | 7 +- Types.hs | 7 +- debug-me.hs | 289 ++++++++++++++++++++++++++++++++++++++++++------------------ 5 files changed, 277 insertions(+), 107 deletions(-) diff --git a/Crypto.hs b/Crypto.hs index a99d497..d973034 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes #-} + module Crypto where import Val @@ -13,27 +15,68 @@ import Data.ByteString dummySignature :: Signature dummySignature = OtherSignature (Val mempty) --- | Sign any Hashable value. -sign :: Hashable v => MySessionKey -> v -> Signature +class Signed t where + getSignature :: t -> Signature + hashExceptSignature :: t -> Hash + mkSigned :: MySessionKey -> (Signature -> t) -> t + mkSigned sk mk = + let tmp = mk dummySignature + in mk (sign sk tmp) + +instance Hashable a => Signed (Activity a) where + getSignature = activitySignature + hashExceptSignature (Activity a mp _s) = hash $ + Tagged "Activity" [hash a, hash mp] + +instance Signed Control where + getSignature = controlSignature + hashExceptSignature (Control a _s) = hash $ + Tagged "Control" a + +instance Hashable t => Signed (Message t) where + getSignature (ActivityMessage a) = getSignature a + getSignature (ControlMessage c) = getSignature c + hashExceptSignature (ActivityMessage a) = hashExceptSignature a + hashExceptSignature (ControlMessage c) = hashExceptSignature c + +sign :: Signed v => MySessionKey -> v -> Signature sign (MySessionKey sk pk) v = Ed25519Signature $ Val $ convert $ - Ed25519.sign sk pk $ val $ hashValue $ hash v - --- | Verifiy a signature of any Hashable value. --- --- To avoid overhead of converting the PublicKey to the Ed25519.PublicKey --- each time, partially evaluate this function. -verify :: Hashable v => PublicKey -> v -> Signature -> Bool -verify (PublicKey (Val pk) _) v (Ed25519Signature (Val s)) = + Ed25519.sign sk pk (toSign v) + +toSign :: Signed v => v -> ByteString +toSign = val . hashValue . hashExceptSignature + +-- | Verifiy the signature of a Signed value. +verifySigned :: Signed v => SigVerifier -> v -> Bool +verifySigned (SigVerifier verifier) v = + case getSignature v of + Ed25519Signature (Val s) -> + case Ed25519.signature s of + CryptoPassed sig -> verifier (toSign v) sig + CryptoFailed _ -> False + OtherSignature _ -> False + +data SigVerifier = SigVerifier (ByteString -> Ed25519.Signature -> Bool) + +mkSigVerifier :: PublicKey -> SigVerifier +mkSigVerifier (PublicKey (Val pk) _) = case Ed25519.publicKey pk of - CryptoPassed pk' -> case Ed25519.signature s of - CryptoPassed sig -> - Ed25519.verify pk' (val $ hashValue $ hash v) sig - CryptoFailed _ -> False - CryptoFailed _ -> False -verify _ _ (OtherSignature _) = False + CryptoPassed pk' -> SigVerifier (Ed25519.verify pk') + CryptoFailed _ -> mempty + +instance Monoid SigVerifier where + mempty = SigVerifier $ \_b _s -> False + mappend (SigVerifier a) (SigVerifier b) = + SigVerifier $ \d s -> b d s || a d s data MySessionKey = MySessionKey Ed25519.SecretKey Ed25519.PublicKey +-- TODO add gpg signature when available +myPublicKey :: MySessionKey -> IO PublicKey +myPublicKey (MySessionKey _ pk) = do + let gpgsig = Nothing + return $ PublicKey (Val (convert pk)) gpgsig + genMySessionKey :: IO MySessionKey genMySessionKey = do -- Crypto.Random.Entropy may use rdrand, or /dev/random. diff --git a/Hash.hs b/Hash.hs index e22abf3..bef3ae0 100644 --- a/Hash.hs +++ b/Hash.hs @@ -45,6 +45,12 @@ instance Hashable Entered where instance Hashable Seen where hash v = hash $ Tagged "Seen" [hash (seenData v)] +instance Hashable ControlAction where + hash (Rejected a) = hash $ Tagged "Rejected" a + hash (SessionKey pk) = hash $ Tagged "SessionKey" pk + hash (SessionKeyAccepted pk) = hash $ Tagged "SessionKeyAccepted" pk + hash (SessionKeyRejected pk) = hash $ Tagged "SessionKeyRejected" pk + instance Hashable Signature where hash (Ed25519Signature s) = hash $ Tagged "Ed25519Signature" s hash (OtherSignature s) = hash $ Tagged "OtherSignature" s diff --git a/TODO b/TODO index 89f8cd9..f9f51b7 100644 --- a/TODO +++ b/TODO @@ -6,13 +6,12 @@ matter.) * loadLog should verify the hashes (and signatures) in the log, and refuse to use logs that are not valid proofs of a session. -* Encryption! -* Add random nonce to start message, to avoid replay issues. - (Or perhaps the encryption derives a RSA key in a way that avoids - replay..) * Network! * Server! * gpg key downloading, web of trust checking, prompting Alternatively, let debug-me be started with a gpg key, this way a project's website can instruct their users to "run debug-me --trust-gpg-key=whatever" +* Multiple developers should be able to connect to a single debug-me + user. Most of the code was written with that in mind, but not tested + yet.. diff --git a/Types.hs b/Types.hs index 27c9e67..e20228d 100644 --- a/Types.hs +++ b/Types.hs @@ -50,6 +50,9 @@ instance DataSize a => DataSize (Message a) where -- to a previous Activity. -- -- 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, +-- which is why it's part of the Activity. data Activity a = Activity { activity :: a , prevActivity :: Maybe Hash @@ -119,7 +122,7 @@ instance DataSize Signature where -- | A public key used for a debug-me session. -- It may be signed with a gpg key. data PublicKey = PublicKey Val (Maybe GpgSig) - deriving (Show, Generic) + deriving (Show, Generic, Eq) instance DataSize PublicKey where -- ed25519 public keys are 32 bytes @@ -127,7 +130,7 @@ instance DataSize PublicKey where -- | A signature made with a gpg key. newtype GpgSig = GpgSig Val - deriving (Show, Generic) + deriving (Show, Generic, Eq) instance DataSize GpgSig where dataSize (GpgSig s) = dataSize s 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