diff options
| -rw-r--r-- | CmdLine.hs | 10 | ||||
| -rw-r--r-- | ControlWindow.hs | 88 | ||||
| -rw-r--r-- | Gpg.hs | 30 | ||||
| -rw-r--r-- | Gpg/Wot.hs | 13 | ||||
| -rw-r--r-- | Role/User.hs | 67 | ||||
| -rw-r--r-- | TODO | 7 | ||||
| -rw-r--r-- | debug-me.1 | 5 |
7 files changed, 124 insertions, 96 deletions
@@ -19,8 +19,7 @@ data Mode | ControlMode ControlOpts data UserOpts = UserOpts - { gpgOpts :: [String] - , cmdToRun :: Maybe (String, [String]) + { cmdToRun :: Maybe (String, [String]) } type UrlString = String @@ -69,12 +68,7 @@ parseMode = (UserMode <$> parseuser) <|> (ControlMode <$> parsecontrol) where parseuser = UserOpts - <$> many (option str - ( long "gpg-opt" - <> short 'g' - <> help "option to pass to gpg" - )) - <*> optional ((,) + <$> optional ((,) <$> strArgument (metavar "cmd") <*> many (strArgument (metavar "opts"))) parsedeveloper = DeveloperOpts diff --git a/ControlWindow.hs b/ControlWindow.hs index cc63cef..02cffd6 100644 --- a/ControlWindow.hs +++ b/ControlWindow.hs @@ -8,6 +8,8 @@ import Types import CmdLine import ControlSocket import VirtualTerminal +import Gpg +import Gpg.Wot import System.IO import System.Environment @@ -18,7 +20,8 @@ import Control.Concurrent.STM import Control.Concurrent.STM.TMChan import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.ByteString.UTF8 (fromString) +import Data.ByteString.UTF8 (fromString, toString) +import Data.Char import Control.Monad import Data.Monoid import Prelude @@ -38,7 +41,7 @@ controlWindow _ = do -- window is open. atomically $ writeTMChan ochan ControlWindowOpened _ <- connectControlSocket socketfile ichan ochan - `race` displayInput ichan promptchan responsechan + `race` displayInput ochan ichan promptchan responsechan `race` collectOutput ochan promptchan responsechan return () @@ -66,39 +69,76 @@ openControlWindow = do return (ichan, ochan) type Prompt = () -type Response = L.ByteString +type Response = B.ByteString type PromptChan = TChan Prompt type ResponseChan = TChan Response -displayInput :: TMChan ControlInput -> PromptChan -> ResponseChan -> IO () -displayInput ichan promptchan responsechan = loop +collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO () +collectOutput ochan promptchan responsechan = do + myusername <- fromString <$> getLoginName + withLines stdin $ mapM_ $ processline myusername + where + processline myusername l = atomically $ do + -- Is any particular input being prompted for now? + mp <- tryReadTChan promptchan + case mp of + Just _ -> writeTChan responsechan $ L.toStrict l + Nothing -> writeTMChan ochan $ ControlOutputAction $ + ChatMessage (Val myusername) (Val $ L.toStrict l) + +displayInput :: TMChan ControlOutput -> TMChan ControlInput -> PromptChan -> ResponseChan -> IO () +displayInput ochan ichan promptchan responsechan = loop where loop = go =<< atomically (readTMChan ichan) go Nothing = return () - go (Just (ControlInputAction (SessionKey (GpgSigned _ devgpgsig)))) = do - error "TODO verify developer key" + go (Just (ControlInputAction (SessionKey k))) = do + askToAllow ochan promptchan responsechan k + loop go (Just (ControlInputAction (ChatMessage username msg))) = do B.putStr $ "<" <> val username <> "> " <> val msg putStr "\n" hFlush stdout loop - go v = do - print v - loop + go _ = loop -collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO () -collectOutput ochan promptchan responsechan = do - myusername <- fromString <$> getLoginName - withLines stdin $ mapM_ $ processline myusername +askToAllow :: TMChan ControlOutput -> PromptChan -> ResponseChan -> PerhapsSigned PublicKey -> IO () +askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $ + ControlOutputAction $ SessionKeyRejected pk +askToAllow ochan promptchan responsechan k@(GpgSigned pk _) = do + putStrLn "Someone wants to connect to this debug-me session." + putStrLn "Checking their Gnupg signature ..." + v <- gpgVerify [] k + let reject = do + putStrLn "Rejecting their connection." + atomically $ writeTMChan ochan $ + ControlOutputAction $ SessionKeyRejected pk + let accept = do + putStrLn "Accepting their connection. They can now enter commands in this debug-me session." + atomically $ writeTMChan ochan $ + ControlOutputAction $ SessionKeyAccepted pk + case v of + Nothing -> do + putStrLn "Unable to download their Gnupg key, or signature verification failed." + reject + Just gpgkeyid -> do + putStrLn "Checking the Gnupg web of trust ..." + ss <- isInStrongSet gpgkeyid + ws <- downloadWotStats gpgkeyid + putStrLn $ describeWot ws ss + ok <- promptconnect + if ok + then accept + else reject where - processline myusername l - | "/" `L.isPrefixOf` l = atomically $ do - -- Is any particular input being prompted for now? - mp <- tryReadTChan promptchan - case mp of - Nothing -> return () - Just _ -> writeTChan responsechan (L.drop 1 l) - | otherwise = atomically $ - writeTMChan ochan $ ControlOutputAction $ - ChatMessage (Val myusername) (Val $ L.toStrict l) + promptconnect = do + atomically $ writeTChan promptchan () + putStr "Let them connect to the debug-me session and run commands? [y/n] " + hFlush stdout + r <- atomically $ readTChan responsechan + case map toLower (toString r) of + "y" -> return True + "yes" -> return True + "n" -> return False + "no" -> return False + _ -> promptconnect @@ -7,6 +7,7 @@ import Crypto import Data.ByteArray (convert) import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as B8 import System.IO import System.Posix.IO hiding (createPipe) import System.Process @@ -17,6 +18,7 @@ import System.Directory import Control.Concurrent.Async newtype GpgKeyId = GpgKeyId String + deriving (Show) newtype GpgSign = GpgSign Bool @@ -58,16 +60,17 @@ gpgSign pk = do -- Gpg outputs to stderr information about who signed the -- data, so that will be visible to the user when eg, prompting -- them if they want to accept a connection from that person. +-- +-- This relies on gpgSign using --clearsign, so on successful +-- verification, the JSON encoded PublicKey is output to gpg's +-- stdout. gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO (Maybe GpgKeyId) gpgVerify _ (UnSigned _) = return Nothing gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do (statusreadh, statuswriteh) <- createPipe statuswritefd <- handleToFd statuswriteh - -- This relies on gpgSign using --clearsign, so on successful - -- verification, the JSON encoded PublicKey is output to gpg's - -- stdout. (Just hin, Just hout, _, pid) <- createProcess $ - (proc "gpg" (extraopts ++ ["--verify", "--output", "-"])) + (proc "gpg" (verifyopts statuswritefd)) { std_in = CreatePipe , std_out = CreatePipe } @@ -78,14 +81,21 @@ gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do (signeddata, gpgkeyid) <- B.hGetContents hout `concurrently` (parseStatusFd <$> hGetContents statusreadh) st <- waitForProcess pid - return $ case st of - ExitSuccess - | val (hashValue (hash pk)) == signeddata -> gpgkeyid - _ -> Nothing + let norm = filter (not . B.null) . B8.lines + let pkissigned = norm (val (hashValue (hash pk))) == norm signeddata + return $ if st == ExitSuccess && pkissigned + then gpgkeyid + else Nothing where extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts then gpgopts - else map ("--keyserver=" ++) defaultKeyServers ++ gpgopts + else concatMap (\s -> ["--keyserver", s]) defaultKeyServers + ++ gpgopts + verifyopts statuswritefd = extraopts ++ + [ "--status-fd", show statuswritefd + , "--verify" + , "--output", "-" + ] -- | Default keyservers to use. defaultKeyServers :: [String] @@ -98,5 +108,5 @@ parseStatusFd :: String -> Maybe GpgKeyId parseStatusFd = go . map words . lines where go [] = Nothing - go ((_:"VALIDSIG":keyid:_):_) = Just (GpgKeyId keyid) + go ((_:"VALIDSIG":_:_:_:_:_:_:_:_:_:keyid:_):_) = Just (GpgKeyId keyid) go (_:rest) = go rest @@ -84,26 +84,31 @@ knownKeyInStrongSet :: GpgKeyId knownKeyInStrongSet = GpgKeyId "E85A5F63B31D24C1EBF0D81CC910D9222512E3C7" newtype StrongSetAnalysis = StrongSetAnalysis Bool + deriving (Show) isInStrongSet :: GpgKeyId -> IO StrongSetAnalysis isInStrongSet k = maybe (StrongSetAnalysis False) (const $ StrongSetAnalysis True) <$> downloadWotPath k knownKeyInStrongSet -describeWot :: WotStats -> StrongSetAnalysis -> String -describeWot ws (StrongSetAnalysis ss) +describeWot :: Maybe WotStats -> StrongSetAnalysis -> String +describeWot (Just ws) (StrongSetAnalysis ss) | ss == False = theirname ++ "'s identity cannot be verified!" | otherwise = unlines $ [ theirname ++ "'s identity has been verified by as many as " ++ show (length sigs) ++ " people, including:" - , intercalate ", " $ take 10 $ map (stripEmail . uid) bestconnectedsigs + , intercalate ", " $ take 10 $ nub $ + map (stripEmail . uid) bestconnectedsigs , "" , theirname ++ " is probably a real person." ] where theirname = stripEmail (uid (key ws)) sigs = cross_sigs ws ++ other_sigs ws - nsigs = length sigs bestconnectedsigs = sortOn rank sigs +describeWot Nothing _ = unlines + [ "" + , "Their identity cannot be verified!" + ] stripEmail :: String -> String stripEmail = unwords . takeWhile (not . ("<" `isPrefixOf`)) . words diff --git a/Role/User.hs b/Role/User.hs index bbf563c..0929f74 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -202,33 +202,13 @@ sendPtyInput ichan ochan controlinput p us logger = go go Just (InputMessage msg@(ControlMessage (Control c _))) -> do logger $ Developer msg - case c of - SessionKey pk -> do - checkDeveloperPublicKey ochan us logger pk - go - ChatMessage _ _ -> do - atomically $ writeTMChan controlinput (ControlInputAction c) - go - Rejected r -> error $ "User side received a Rejected: " ++ show r - SessionKeyAccepted _ -> error "User side received a SessionKeyAccepted" - SessionKeyRejected _ -> error "User side received a SessionKeyRejected" + atomically $ writeTMChan controlinput (ControlInputAction c) + go Just (RejectedMessage rej) -> do logger $ User rej go Just (BadlySignedMessage _) -> go -sendControlOutput :: TMChan ControlOutput -> TMChan (Message Seen) -> TVar UserState -> Logger -> IO () -sendControlOutput controloutput ochan us logger = loop - where - loop = go =<< atomically (readTMChan controloutput) - go Nothing = return () - go (Just ControlWindowOpened) = loop - go (Just (ControlOutputAction c)) = do - now <- getPOSIXTime - l <- atomically $ sendDeveloper ochan us c now - logger (User l) - loop - data Input = InputMessage (Message Entered) | RejectedMessage (Message Seen) @@ -276,25 +256,6 @@ getDeveloperMessage' msg ochan us now = do 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 sigVerifier. -checkDeveloperPublicKey :: TMChan (Message Seen) -> TVar UserState -> Logger -> PerhapsSigned PublicKey -> IO () -checkDeveloperPublicKey ochan us logger spk = do - now <- getPOSIXTime - -- TODO check gpg sig.. - msg <- atomically $ do - st <- readTVar us - let sv = sigVerifier st - let sv' = sv `mappend` mkSigVerifier pk - let st' = st { sigVerifier = sv' } - writeTVar us st' - sendDeveloper ochan us (SessionKeyAccepted pk) now - logger $ User msg - where - pk = case spk of - GpgSigned k _ -> k - UnSigned k -> k - -- | Truncate the Backlog to remove entries older than the one -- that the Activity Entered refers to, but only if the referred -- to Activity is an Activity Seen. @@ -357,3 +318,27 @@ isLegalEntered (Activity a (Just hp) _ _) us (lastact :| bl) = backLog us getseen (User (ActivityMessage as)) = seenData $ activity as getseen _ = mempty + +-- | Forward messages from the control window to the developer. +-- +-- When the control window sends a SessionKeyAccepted, add it to the +-- sigVerifier. +sendControlOutput :: TMChan ControlOutput -> TMChan (Message Seen) -> TVar UserState -> Logger -> IO () +sendControlOutput controloutput ochan us logger = loop + where + loop = go =<< atomically (readTMChan controloutput) + go Nothing = return () + go (Just ControlWindowOpened) = loop + go (Just (ControlOutputAction c)) = do + case c of + SessionKeyAccepted pk -> atomically $ do + st <- readTVar us + let sv = sigVerifier st + let sv' = sv `mappend` mkSigVerifier pk + let st' = st { sigVerifier = sv' } + writeTVar us st' + _ -> return () + now <- getPOSIXTime + l <- atomically $ sendDeveloper ochan us c now + logger (User l) + loop @@ -1,3 +1,6 @@ +* When user rejects developer, the debug-me --debug prints + "User did not grant access to their terminal." and says the session + log is done, but keeps running. * GPG WoT is checked by querying pgp.cs.uu.nl, could use wotsap if it's locally installed. However, the version of wotsap in debian only supports short, insecure keyids, so is less secure than using the server. @@ -43,10 +46,6 @@ * Add a mode that, given a log file, displays what developer(s) gpg keys signed activity in the log file. For use when a developer did something wrong, to examine the proof of malfesence. -* 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" * How to prevent abusing servers to store large quantities of data that are not legitimate debug-me logs, but are formatted like them? Perhaps add POW to the wire protocol? Capthca? @@ -39,11 +39,6 @@ will keep most developers honest. .IP "-- cmd opts" Normally debug-me will run your login shell. To run some other command, pass the command and any options after "--". -.IP "--gpg-opt=option" -debug-me runs gpg to verify the GPG key of a developer. To pass options to -gpg, use --gpg-opt with the option to pass. For example: ---gpg-opt=--keyserver=pgpkeys.mit.edu -This can be done multiple times. .SH DEVELOPER OPTIONS .IP "--debug url" Connect to a debug-me session on the specified url. The developer runs |