server: email logs to user, and option to delete old ones

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