From fe3c26650bb1e267cce756831fdb9cde230cafd5 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 21 Apr 2017 21:06:04 -0400
Subject: use UUID to generate a unique SessionID

---
 Role/Developer.hs |  2 ++
 Server.hs         |  3 +--
 SessionID.hs      | 19 ++++++++++++++++---
 WebSockets.hs     |  7 +++----
 debug-me.cabal    |  2 ++
 5 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/Role/Developer.hs b/Role/Developer.hs
index a53e841..4ff0cda 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -76,7 +76,9 @@ sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO (
 sendTtyInput ichan devstate logger = go
   where
 	go = do
+		print "in  sendTtyInput"
 		b <- B.hGetSome stdin 1024
+		print "sending from dev"
 		if b == B.empty
 			then return ()
 			else send b
diff --git a/Server.hs b/Server.hs
index 4fa80a7..3dd94be 100644
--- a/Server.hs
+++ b/Server.hs
@@ -17,7 +17,6 @@ import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
 import Control.Concurrent.Async
 import qualified Data.Map as M
-import System.IO
 import Control.Exception
 import Data.Time.Clock.POSIX
 
@@ -40,7 +39,7 @@ app o ssv = websocketsOr WS.defaultConnectionOptions (websocketApp o ssv) webapp
 websocketApp :: ServerOpts -> TVar ServerState -> WS.ServerApp
 websocketApp o ssv pending_conn = do
 	conn <- WS.acceptRequest pending_conn
-	wv <- negotiateWireVersion conn
+	_v <- negotiateWireVersion conn
 	theirmode <- getMode conn
 	case theirmode of
 		InitMode _ -> user o ssv conn
diff --git a/SessionID.hs b/SessionID.hs
index 71f2150..3827e1d 100644
--- a/SessionID.hs
+++ b/SessionID.hs
@@ -13,10 +13,13 @@ import Serialization
 import System.FilePath
 import Data.Text
 import System.IO
+import System.Directory
 import Network.Wai.Handler.Warp (Port)
 import Network.WebSockets hiding (Message)
 import qualified Data.Aeson
 import Data.Maybe
+import Data.UUID
+import Data.UUID.V4
 
 -- | A SessionID is the base name of the log file to use,
 -- and may not contain any path information.
@@ -48,11 +51,21 @@ sessionLogFile :: FilePath -> SessionID -> FilePath
 sessionLogFile dir (SessionID f) = dir </> "debug-me." ++ f ++ ".log"
 
 -- | Allocate a new SessionID and return an open Handle to its log file.
+--
+-- A UUID is used, to avoid ever generating a SessionID that has been used
+-- before.
 withSessionID :: FilePath -> ((Handle, SessionID) -> IO a) -> IO a
 withSessionID dir a = do
-	-- TODO find an unused log file and open it
-	let sid = SessionID "1"
-	withFile "debug-me-server.log" WriteMode $ \h -> a (h, sid)
+	createDirectoryIfMissing False dir
+	sid <- SessionID . toString <$> nextRandom
+	let f = sessionLogFile dir sid
+	-- File should not already exist, but just in case we get
+	-- spectacularly unlucky (or the RNG is broken..),
+	-- avoid overwriting a log, and try again.
+	exists <- doesFileExist f
+	if exists
+		then withSessionID dir a
+		else withFile f WriteMode $ \h -> a (h, sid)
 
 type UrlString = String
 
diff --git a/WebSockets.hs b/WebSockets.hs
index c7893fb..25f2162 100644
--- a/WebSockets.hs
+++ b/WebSockets.hs
@@ -20,12 +20,12 @@ runClientApp = runClient "localhost" 8081 "/"
 
 -- | Make a client that sends and receives Messages over a websocket.
 clientApp
-	:: (Show sent, WebSocketsData (Message sent), WebSocketsData (Message received))
+	:: (WebSocketsData (Message sent), WebSocketsData (Message received))
 	=> Mode
 	-> (TChan (Message sent) -> TChan (Message received) -> SessionID -> IO a)
 	-> ClientApp a
 clientApp mode a conn = do
-	vs <- negotiateWireVersion conn
+	_v <- negotiateWireVersion conn
 	sendMode conn mode
 	sid <- receiveData conn
 	bracket setup cleanup (go sid)
@@ -51,12 +51,11 @@ relayFromSocket conn sender = go
 		sender msg
 		go
 
-relayToSocket :: Show sent => WebSocketsData (Message sent) => Connection -> (IO (Maybe (Message sent))) -> IO ()
+relayToSocket :: WebSocketsData (Message sent) => Connection -> (IO (Maybe (Message sent))) -> IO ()
 relayToSocket conn getter = go
   where
 	go = do
 		mmsg <- getter
-		print ("got message", mmsg)
 		case mmsg of
 			Nothing -> go
 			Just msg -> do
diff --git a/debug-me.cabal b/debug-me.cabal
index 341189a..54fd56b 100644
--- a/debug-me.cabal
+++ b/debug-me.cabal
@@ -41,6 +41,7 @@ Executable debug-me
     , graphviz (== 2999.18.*)
     , time (>= 1.6)
     , filepath (>= 1.4)
+    , directory (>= 1.3)
     , containers (>= 0.5)
     , unbounded-delays (>= 0.1)
     , memory (>= 0.13)
@@ -49,6 +50,7 @@ Executable debug-me
     , http-types (>= 0.9)
     , websockets (>= 0.10)
     , wai-websockets (>= 3.0)
+    , uuid (>= 1.3)
   Other-Modules:
     CmdLine
     Crypto
-- 
cgit v1.2.3