improve types

Including adding a timestamp to logs

1 files changed, 39 insertions, 25 deletions

diff --git a/debug-me.hs b/debug-me.hs
index 793eb2e..058e23a 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -20,6 +20,7 @@ import Data.List
 import Data.List.NonEmpty (NonEmpty(..), toList)
 import Data.Monoid
 import Data.Aeson
+import Data.Time.Clock.POSIX
 
 main :: IO ()
 main = do
@@ -52,7 +53,7 @@ networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit
 developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
 developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do
 	startact <- atomically $ readTChan ochan
-	logger $ ActivitySeen (startact, hash startact)
+	logger $ ActivitySeen startact
 	case startact of
 		Activity (Proto (Seen (Val b))) Nothing sig -> do
 			B.hPut stdout b
@@ -107,7 +108,7 @@ sendTtyInput ichan devstate logger = go
 				}
 			writeTVar devstate ds'
 			return act
-		logger $ ActivityEntered (act, hash act)
+		logger $ ActivityEntered act
 		go
 
 -- | Read activity from the TChan and display it to the developer.
@@ -116,7 +117,7 @@ sendTtyOutput ochan devstate logger = go
   where
 	go = do
 		(v, act) <- atomically $ processOutput ochan devstate
-		logger $ ActivitySeen (act, hash act)
+		logger $ ActivitySeen act
 		case v of
 			ProtocolError e -> protocolError e
 			TtyOutput b -> do
@@ -201,8 +202,8 @@ isLegalSeen (Activity _ Nothing _) ds = (False, ds)
 user :: B.ByteString -> Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
 user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do
 	let startact = Activity (Proto (Seen (Val (startmsg <> "\r\n")))) Nothing dummySignature
-	let l = ActivitySeen (startact, hash startact)
-	logger l
+	logger $ ActivitySeen startact
+	l <- mkActivityLog (ActivitySeen startact) <$> getPOSIXTime
 	atomically $ writeTChan ochan startact
 	backlog <- newTVarIO $ Backlog (l :| [])
 	_ <- sendPtyOutput p ochan backlog logger
@@ -213,36 +214,48 @@ user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do
 data Backlog = Backlog (NonEmpty ActivityLog)
 	deriving (Show)
 
-type Logger = ActivityLog -> IO ()
+type Logger = SomeActivity -> IO ()
 
 withLogger :: FilePath -> (Logger -> IO a) -> IO a
 withLogger logfile a = withFile logfile WriteMode (a . mkLogger)
 
 mkLogger :: Handle -> Logger
 mkLogger h a = do
-	L.hPut h (encode a)
+	l <- mkActivityLog a <$> getPOSIXTime
+	L.hPut h (encode l)
 	hPutStr h "\n"
 	hFlush h
 
+mkActivityLog :: SomeActivity -> POSIXTime -> ActivityLog
+mkActivityLog a now = ActivityLog
+	{ loggedActivity = a
+	, loggedHash = case a of
+		ActivitySeen s -> hash s
+		ActivityEntered e -> hash e
+	, loggedTimestamp = now
+	}
+
 -- | Forward things written to the Pty out the TChan.
 sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> Logger -> IO ()
 sendPtyOutput p ochan backlog logger = go
   where
 	go = do
 		b <- readPty p
+		now <- getPOSIXTime
 		act <- atomically $ do
 			let seen = Seen (Val b)
-			sendDeveloper ochan backlog (Proto seen)
-		logger $ ActivitySeen (act, hash act)
+			sendDeveloper ochan backlog (Proto seen) now
+		logger $ ActivitySeen act
 		go
 
-sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> STM (Activity Seen)
-sendDeveloper ochan backlog pseen = do
+sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> POSIXTime -> STM (Activity Seen)
+sendDeveloper ochan backlog pseen now = do
 	Backlog (bl@(prev :| _)) <- readTVar backlog
-	let prevhash = activityLogHash prev
+	let prevhash = loggedHash prev
 	let act = Activity pseen (Just prevhash) dummySignature
+	let l = mkActivityLog (ActivitySeen act) now
 	writeTChan ochan act
-	writeTVar backlog (Backlog (ActivitySeen (act, hash act) :| toList bl))
+	writeTVar backlog $ Backlog (l :| toList bl)
 	return act
 
 -- | Read things to be entered from the TChan, verify if they're legal,
@@ -252,6 +265,7 @@ sendPtyInput ichan ochan p backlog logger = go
   where
 	go = do
 		networkDelay
+		now <- getPOSIXTime
 		v <- atomically $ do
 			entered <- readTChan ichan
 			bl <- readTVar backlog
@@ -260,21 +274,21 @@ sendPtyInput ichan ochan p backlog logger = go
 			let bl'@(Backlog bll) = truncateBacklog bl entered
 			if isLegalEntered entered bl'
 				then do
-					let l = ActivityEntered (entered, hash entered)
+					let l = mkActivityLog (ActivityEntered entered) now
 					writeTVar backlog (Backlog (l :| toList bll))
-					return (Right (entered, l))
+					return (Right entered)
 				else do
 					let reject = Rejected entered
-					Left <$> sendDeveloper ochan backlog reject
+					Left <$> sendDeveloper ochan backlog reject now
 		case v of
-			Right (entered, l) -> do
-				logger l
+			Right entered -> do
+				logger (ActivityEntered entered)
 				case activity entered of
 					Proto e -> writePty p (val (enteredData e))
 					Rejected r -> protocolError $ "User side received a Rejected: " ++ show r
 				go
 			Left rejact -> do
-				logger $ ActivitySeen (rejact, hash rejact)
+				logger $ ActivitySeen rejact
 				go
 
 -- | Truncate the Backlog to remove entries older than the one
@@ -296,7 +310,7 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _)
 	go c (x:xs)
 		| truncationpoint x = reverse (x:c)
 		| otherwise = go (x:c) xs
-	truncationpoint x@(ActivitySeen {}) = Just (activityLogHash x) == hp
+	truncationpoint x@(ActivityLog { loggedActivity = ActivitySeen {}}) = Just (loggedHash x) == hp
 	truncationpoint _ = False
 
 -- | Entered activity is legal when it points to the last Seen activvity,
@@ -310,14 +324,14 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _)
 -- most recent Seen activity.
 isLegalEntered :: Activity Entered -> Backlog -> Bool
 isLegalEntered (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl))
-	| Just (activityLogHash lastseen) == hp = True
+	| Just (loggedHash lastseen) == hp = True
 	| B.null (val (echoData entered)) = False -- optimisation
-	| any (== hp) (map (Just . activityLogHash) bl) =
-		let sincehp = reverse (lastseen : takeWhile (\l -> Just (activityLogHash l) /= hp) bl)
-		in echoData entered == mconcat (map getseen sincehp)
+	| any (== hp) (map (Just . loggedHash) bl) =
+		let sincehp = reverse (lastseen : takeWhile (\l -> Just (loggedHash l) /= hp) bl)
+		in echoData entered == mconcat (map (getseen . loggedActivity) sincehp)
 	| otherwise = False
   where
-	getseen (ActivitySeen (a, _)) = case activity a of
+	getseen (ActivitySeen a)  = case activity a of
 		Proto s -> seenData s
 		_ -> mempty
 	getseen (ActivityEntered _) = mempty