From 1d18dcbe796820b30e0c8c1db241da95ee7566cb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 18 Apr 2017 13:04:16 -0400 Subject: improve types Including adding a timestamp to logs --- debug-me.hs | 64 +++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 39 insertions(+), 25 deletions(-) (limited to 'debug-me.hs') 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 -- cgit v1.2.3