From 7c0cd342cc339a414e9da40c1498a35cc580d827 Mon Sep 17 00:00:00 2001
From: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
Date: Sat, 8 May 2021 14:49:17 +0400
Subject: [PATCH] show message timestamps (#55)

---
 apps/dog-food/ChatTerminal.hs      |  8 ++++++-
 apps/dog-food/ChatTerminal/Core.hs | 16 +++++++++----
 apps/dog-food/Main.hs              | 37 +++++++++++++++++++++---------
 package.yaml                       |  1 +
 4 files changed, 45 insertions(+), 17 deletions(-)

diff --git a/apps/dog-food/ChatTerminal.hs b/apps/dog-food/ChatTerminal.hs
index 9a09027d16..cb61daddbb 100644
--- a/apps/dog-food/ChatTerminal.hs
+++ b/apps/dog-food/ChatTerminal.hs
@@ -18,6 +18,9 @@ import ChatTerminal.Editor
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (race_)
 import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Time.LocalTime (getZonedTime)
 import Numeric.Natural
 import Styled
 import System.Terminal
@@ -89,7 +92,10 @@ receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
         writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
         writeTBQueue inputQ s
         return s
-      withTermLock ct $ printMessage ct [styleMessage msg]
+      withTermLock ct $ do
+        localTime <- liftIO getZonedTime
+        let localTimeStr = formatTime defaultTimeLocale "%H:%M" localTime
+        printMessage ct [styleMessage localTimeStr msg]
 
 sendToTTY :: ChatTerminal -> IO ()
 sendToTTY ct = forever $ do
diff --git a/apps/dog-food/ChatTerminal/Core.hs b/apps/dog-food/ChatTerminal/Core.hs
index ca6977901b..8e5632a312 100644
--- a/apps/dog-food/ChatTerminal/Core.hs
+++ b/apps/dog-food/ChatTerminal/Core.hs
@@ -113,15 +113,21 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition
          in min (length s) $ p + length after - length afterWord
     ts' (s', p') = ts {inputString = s', inputPosition = p'}
 
-styleMessage :: String -> StyledString
-styleMessage = \case
-  "" -> ""
-  s@('@' : _) -> let (c, rest) = span (/= ' ') s in styled (Colored Cyan) c <> markdown rest
-  s -> markdown s
+styleMessage :: String -> String -> StyledString
+styleMessage time msg = do
+  case msg of
+    "" -> ""
+    s@('@' : _) -> do
+      let (c, rest) = span (/= ' ') s
+      styleTime time <> " " <> styled (Colored Cyan) c <> markdown rest
+    s -> markdown s
   where
     markdown :: String -> StyledString
     markdown = styleMarkdownText . T.pack
 
+styleTime :: String -> StyledString
+styleTime = Styled [SetColor Foreground Vivid Black]
+
 safeDecodeUtf8 :: ByteString -> Text
 safeDecodeUtf8 = decodeUtf8With onError
   where
diff --git a/apps/dog-food/Main.hs b/apps/dog-food/Main.hs
index a4ce6b868a..70549ff05e 100644
--- a/apps/dog-food/Main.hs
+++ b/apps/dog-food/Main.hs
@@ -24,6 +24,9 @@ import Data.Functor (($>))
 import Data.List (intersperse)
 import qualified Data.Text as T
 import Data.Text.Encoding
+import Data.Time.Clock (DiffTime, UTCTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Time.LocalTime
 import Numeric.Natural
 import Simplex.Markdown
 import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient)
@@ -87,7 +90,7 @@ data ChatResponse
   | Invitation SMPQueueInfo
   | Connected Contact
   | Confirmation Contact
-  | ReceivedMessage Contact ByteString MsgIntegrity
+  | ReceivedMessage Contact UTCTime ByteString MsgIntegrity
   | Disconnected Contact
   | YesYes
   | ContactError ConnectionErrorType Contact
@@ -95,8 +98,8 @@ data ChatResponse
   | ChatError AgentErrorType
   | NoChatResponse
 
-serializeChatResponse :: ChatOpts -> ChatResponse -> [StyledString]
-serializeChatResponse _ = \case
+serializeChatResponse :: ChatOpts -> TimeZone -> ZonedTime -> ChatResponse -> [StyledString]
+serializeChatResponse _ localTz currentTime = \case
   ChatHelpInfo -> chatHelpInfo
   MarkdownInfo -> markdownInfo
   Invitation qInfo ->
@@ -108,8 +111,8 @@ serializeChatResponse _ = \case
     ]
   Connected c -> [ttyContact c <> " connected"]
   Confirmation c -> [ttyContact c <> " ok"]
-  ReceivedMessage c t mi ->
-    prependFirst (ttyFromContact c) (msgPlain t)
+  ReceivedMessage c utcTime t mi ->
+    prependFirst (formatUTCTime utcTime <> " " <> ttyFromContact c) (msgPlain t)
       ++ showIntegrity mi
   Disconnected c -> ["disconnected from " <> ttyContact c <> " - restart chat"]
   YesYes -> ["you got it!"]
@@ -124,6 +127,15 @@ serializeChatResponse _ = \case
     prependFirst :: StyledString -> [StyledString] -> [StyledString]
     prependFirst s [] = [s]
     prependFirst s (s' : ss) = (s <> s') : ss
+    formatUTCTime :: UTCTime -> StyledString
+    formatUTCTime utcTime = do
+      let localTime = utcToLocalTime localTz utcTime
+          format =
+            if (localDay localTime < localDay (zonedTimeToLocalTime currentTime))
+              && (timeOfDayToTime (localTimeOfDay localTime) > (6 * 60 * 60 :: DiffTime))
+              then "%m-%d" -- if message is from yesterday or before and 6 hours has passed since midnight
+              else "%H:%M"
+      styleTime $ formatTime defaultTimeLocale format localTime
     msgPlain :: ByteString -> [StyledString]
     msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
     showIntegrity :: MsgIntegrity -> [StyledString]
@@ -207,10 +219,11 @@ welcomeGetOpts = do
 dogFoodChat :: ChatClient -> ChatTerminal -> Env -> ChatOpts -> IO ()
 dogFoodChat t ct env opts = do
   c <- runReaderT getSMPAgentClient env
+  localTz <- liftIO getCurrentTimeZone
   raceAny_
     [ runReaderT (runSMPAgentClient c) env,
       sendToAgent t ct c,
-      sendToChatTerm t ct opts,
+      sendToChatTerm t ct opts localTz,
       receiveFromAgent t ct c,
       receiveFromChatTerm t ct,
       chatTerminal ct
@@ -237,11 +250,13 @@ receiveFromChatTerm t ct = forever $ do
       Right cmd -> atomically $ writeTBQueue (inQ t) cmd
     writeOutQ = atomically . writeTBQueue (outQ t)
 
-sendToChatTerm :: ChatClient -> ChatTerminal -> ChatOpts -> IO ()
-sendToChatTerm ChatClient {outQ} ChatTerminal {outputQ} opts = forever $ do
+sendToChatTerm :: ChatClient -> ChatTerminal -> ChatOpts -> TimeZone -> IO ()
+sendToChatTerm ChatClient {outQ} ChatTerminal {outputQ} opts localTz = forever $ do
   atomically (readTBQueue outQ) >>= \case
     NoChatResponse -> return ()
-    resp -> atomically . writeTBQueue outputQ $ serializeChatResponse opts resp
+    resp -> do
+      currentTime <- liftIO getZonedTime
+      atomically . writeTBQueue outputQ $ serializeChatResponse opts localTz currentTime resp
 
 sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
 sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do
@@ -278,7 +293,7 @@ receiveFromAgent t ct c = forever . atomically $ do
       INV qInfo -> Invitation qInfo
       CON -> Connected contact
       END -> Disconnected contact
-      MSG {msgBody, msgIntegrity} -> ReceivedMessage contact msgBody msgIntegrity
+      MSG {msgBody, msgIntegrity, brokerMeta} -> ReceivedMessage contact (snd brokerMeta) msgBody msgIntegrity
       SENT _ -> NoChatResponse
       OK -> Confirmation contact
       ERR (CONN e) -> ContactError e contact
@@ -288,7 +303,7 @@ receiveFromAgent t ct c = forever . atomically $ do
     setActiveContact :: ChatResponse -> STM ()
     setActiveContact = \case
       Connected a -> setActive ct a
-      ReceivedMessage a _ _ -> setActive ct a
+      ReceivedMessage a _ _ _ -> setActive ct a
       Disconnected a -> unsetActive ct a
       _ -> pure ()
 
diff --git a/package.yaml b/package.yaml
index 1a4c2d2d00..94c2416407 100644
--- a/package.yaml
+++ b/package.yaml
@@ -30,6 +30,7 @@ executables:
       - stm == 2.5.*
       - terminal == 0.2.*
       - text == 1.2.*
+      - time == 1.9.*
       - unliftio == 0.2.*
     ghc-options:
       - -threaded