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

1 files changed, 27 insertions, 5 deletions

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."