From b0f8a010254b97548b5a7140cc7137c53e30f8cd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Apr 2017 14:58:32 -0400 Subject: server: email logs to user, and option to delete old ones --- CmdLine.hs | 16 +++++++++++++++- Role/User.hs | 9 ++++++++- Server.hs | 32 +++++++++++++++++++++++++++----- TODO | 15 --------------- Types.hs | 9 ++++++--- WebSockets.hs | 7 +++++-- debug-me.1 | 7 +++++++ debug-me.cabal | 1 + 8 files changed, 69 insertions(+), 27 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index a1eda5c..13cb309 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -1,9 +1,12 @@ module CmdLine where +import Types + import Data.Monoid import Options.Applicative import Network.URI import Network.Wai.Handler.Warp (Port) +import qualified Data.Text as T data CmdLine = CmdLine { mode :: Mode @@ -47,6 +50,8 @@ data ReplayOpts = ReplayOpts data ServerOpts = ServerOpts { serverDirectory :: FilePath , serverPort :: Port + , serverEmail :: Maybe EmailAddress + , serverDeleteOldLogs :: Bool } data ControlOpts = ControlOpts @@ -106,7 +111,7 @@ parseMode = (UserMode <$> parseuser) <> help "display a debug-me session non-interactively" ) parseserver = ServerOpts - <$> option str + <$> strOption ( long "server" <> metavar "logdir" <> help "run server, storing logs in the specified directory" @@ -118,6 +123,15 @@ parseMode = (UserMode <$> parseuser) <> showDefault <> help "port for server to listen on" ) + <*> optional (T.pack <$> strOption + ( long "from-email" + <> metavar "address" + <> help "email session logs using this from address" + )) + <*> switch + ( long "delete-old-logs" + <> help "delete session logs after session is done" + ) parsecontrol = ControlOpts <$> switch ( long "control" diff --git a/Role/User.hs b/Role/User.hs index e999b1c..90d19de 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -21,6 +21,7 @@ import Control.Concurrent.STM import Control.Concurrent.STM.TMChan import System.Process import System.Exit +import qualified Data.Text.IO as T import qualified Data.ByteString as B import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Monoid @@ -33,11 +34,17 @@ run :: UserOpts -> IO ExitCode run os = fromMaybe (ExitFailure 101) <$> connect where connect = do + putStrLn "A debug-me session lets someone else run commands on your computer" + putStrLn "to debug your problem. A log of this session can be emailed to you" + putStrLn "at the end, which you can use to prove what they did in this session." + putStr "Enter your email address: " + hFlush stdout + email <- T.getLine (controlinput, controloutput) <- openControlWindow putStr "Connecting to debug-me server..." hFlush stdout usv <- newEmptyTMVarIO - runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ochan ichan sid -> do + runClientApp $ clientApp (InitMode email) 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:" diff --git a/Server.hs b/Server.hs index deafe41..687636a 100644 --- a/Server.hs +++ b/Server.hs @@ -20,12 +20,14 @@ import Control.Concurrent.STM.TMChan import Control.Concurrent.Async import Control.Exception import Control.Monad +import Data.Maybe import qualified Data.Map as M import qualified Data.Text as T import Data.Time.Clock.POSIX import System.IO import System.Directory import System.Mem.Weak +import Network.Mail.Mime type ServerState = M.Map SessionID Session @@ -110,17 +112,20 @@ websocketApp o ssv pending_conn = do _v <- negotiateWireVersion conn r <- receiveData conn case r of - SelectMode ClientSends (InitMode _) -> user o ssv conn + SelectMode ClientSends (InitMode email) -> user email o ssv conn SelectMode ClientSends (ConnectMode t) -> case mkSessionID (T.unpack t) of Nothing -> protocolError conn "Invalid session id!" Just sid -> developer o ssv sid conn _ -> protocolError conn "Expected SelectMode" -user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO () -user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do - sendBinaryData conn (Ready ServerSends sid) - bracket (setup sid loghv) (cleanup sid) go +user :: EmailAddress -> ServerOpts -> TVar ServerState -> WS.Connection -> IO () +user email o ssv conn = do + sid <- withSessionID (serverDirectory o) $ \(loghv, sid) -> do + sendBinaryData conn (Ready ServerSends sid) + bracket (setup sid loghv) (cleanup sid) go + return sid + doneSessionLog email o sid where setup sid loghv = do session <- newSession loghv @@ -236,3 +241,20 @@ replayBacklog o sid conn = do forM_ ls $ \l -> case loggedMessage <$> l of Right m -> sendBinaryData conn (AnyMessage m) Left _ -> return () + +doneSessionLog :: EmailAddress -> ServerOpts -> SessionID -> IO () +doneSessionLog email o sid = do + let logfile = sessionLogFile (serverDirectory o) sid + emailSessionLog email o logfile + if serverDeleteOldLogs o + then removeFile logfile + else return () + +emailSessionLog :: EmailAddress -> ServerOpts -> FilePath -> IO () +emailSessionLog email o logfile = renderSendMail + =<< simpleMail to from subject body body [("text/plain", logfile)] + where + to = Address Nothing email + from = Address Nothing $ fromMaybe "unknown@server" (serverEmail o) + subject = "Your recent debug-me session" + body = "Attached is the log from your recent debug-me session." diff --git a/TODO b/TODO index 6975aff..5ef506c 100644 --- a/TODO +++ b/TODO @@ -23,21 +23,6 @@ to. (Perhaps not needed now that developers see other developer's Activity Entered.. But, this does let developers know what the current accepted line is.) -* 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? - - The user's email address is sent to the server when starting a debug-me - session, and once the session ends, the server emails the log file - to that address. This serves two purposes: - - 1. It makes sure that the user gets a copy of the session log, - which the developer cannot delete. - 2. Once the server has emailed the log, it's free to delete its - copy to free up disk space. Since servers don't have to retain - log files for long, this makes them unattractive to abusers - who might otherwise try to store large quantities of data. - * Client should upload to multiple servers, for redundancy. This way, if Joey runs a server, and Alice runs a server, the user can start debug-me and not worry that Joey will connect, do something bad, and have diff --git a/Types.hs b/Types.hs index 7622f6a..c0eb7dd 100644 --- a/Types.hs +++ b/Types.hs @@ -15,6 +15,7 @@ import Val import Memory import JSON +import qualified Data.Text as T import Data.Time.Clock.POSIX -- | Things that the developer sees. @@ -123,6 +124,8 @@ instance DataSize Hash where data HashMethod = SHA512 | SHA3 deriving (Show, Generic, Eq) +type EmailAddress = T.Text + data Signature = Ed25519Signature Val | OtherSignature Val @@ -172,14 +175,14 @@ instance Monoid ElapsedTime where instance DataSize ElapsedTime where dataSize _ = 16 -- 128 bit Double +instance ToJSON ElapsedTime +instance FromJSON ElapsedTime + data AnyMessage = User (Message Seen) | Developer (Message Entered) deriving (Show, Generic) -instance ToJSON ElapsedTime -instance FromJSON ElapsedTime - instance DataSize AnyMessage where dataSize (User a) = dataSize a dataSize (Developer a) = dataSize a diff --git a/WebSockets.hs b/WebSockets.hs index bbf21e3..17b0170 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -11,6 +11,7 @@ module WebSockets ( negotiateWireVersion, WireProtocol(..), Mode(..), + EmailAddress, ClientSends(..), ServerSends(..), ) where @@ -207,8 +208,10 @@ negotiateWireVersion conn = do -- | Modes of operation that can be requested for a websocket connection. data Mode - = InitMode T.Text -- ^ Text is unused, but reserved for expansion - | ConnectMode T.Text -- ^ Text specifies the SessionID to connect to + = InitMode EmailAddress + -- ^ initialize a new debug-me session. + | ConnectMode T.Text + -- ^ Text specifies the SessionID to connect to deriving (Show, Eq, Generic) instance FromJSON Mode diff --git a/debug-me.1 b/debug-me.1 index 5e679a6..c3366cd 100644 --- a/debug-me.1 +++ b/debug-me.1 @@ -75,6 +75,13 @@ Include hashes in the graphviz visualization. Run a debug-me server, logging to the specified directory. .IP "--port N" Specify a port for the debug-me server to listen to. +.IP "--from-email address" +The server will email session logs to users. It's a good idea to +provide a real email address, otherwise a dummy one will be used. +.IP "--delete-old-logs" +Normally the server will retain old log files so that users and developers +can refer to them. This option makes it delete the log file once the +session is done. .SH FILES .IP "~/.debug-me/log/" Sessions are logged to here. The log file name is displayed when debug-me diff --git a/debug-me.cabal b/debug-me.cabal index dd64c01..01b0557 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -78,6 +78,7 @@ Executable debug-me , cereal (>= 0.5) , utf8-string (>= 1.0) , network-uri (>= 2.6) + , mime-mail (>= 0.4) Other-Modules: ControlWindow ControlSocket -- cgit v1.2.3