From 3d4e4e2ef91ddd6fcace55432ba5769fedcc9fdb Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Sat, 7 Jan 2023 16:38:35 +0000
Subject: [PATCH] core: include commit information in /v response (#1705)

---
 package.yaml                   |  1 +
 simplex-chat.cabal             |  5 +++++
 src/Simplex/Chat.hs            |  2 +-
 src/Simplex/Chat/Controller.hs | 29 ++++++++++++++++++++++++++++-
 src/Simplex/Chat/View.hs       |  6 +++++-
 5 files changed, 40 insertions(+), 3 deletions(-)

diff --git a/package.yaml b/package.yaml
index c78393562..2ac89be66 100644
--- a/package.yaml
+++ b/package.yaml
@@ -27,6 +27,7 @@ dependencies:
   - email-validate == 2.3.*
   - exceptions == 0.10.*
   - filepath == 1.4.*
+  - githash == 0.1.*
   - http-types == 0.12.*
   - mtl == 2.2.*
   - network >= 3.1.2.7 && < 3.2
diff --git a/simplex-chat.cabal b/simplex-chat.cabal
index b8bf55e63..d3f31b4c3 100644
--- a/simplex-chat.cabal
+++ b/simplex-chat.cabal
@@ -108,6 +108,7 @@ library
     , email-validate ==2.3.*
     , exceptions ==0.10.*
     , filepath ==1.4.*
+    , githash ==0.1.*
     , http-types ==0.12.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
@@ -151,6 +152,7 @@ executable simplex-bot
     , email-validate ==2.3.*
     , exceptions ==0.10.*
     , filepath ==1.4.*
+    , githash ==0.1.*
     , http-types ==0.12.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
@@ -195,6 +197,7 @@ executable simplex-bot-advanced
     , email-validate ==2.3.*
     , exceptions ==0.10.*
     , filepath ==1.4.*
+    , githash ==0.1.*
     , http-types ==0.12.*
     , mtl ==2.2.*
     , network >=3.1.2.7 && <3.2
@@ -240,6 +243,7 @@ executable simplex-chat
     , email-validate ==2.3.*
     , exceptions ==0.10.*
     , filepath ==1.4.*
+    , githash ==0.1.*
     , http-types ==0.12.*
     , mtl ==2.2.*
     , network ==3.1.*
@@ -293,6 +297,7 @@ test-suite simplex-chat-test
     , email-validate ==2.3.*
     , exceptions ==0.10.*
     , filepath ==1.4.*
+    , githash ==0.1.*
     , hspec ==2.7.*
     , http-types ==0.12.*
     , mtl ==2.2.*
diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs
index b708e293a..299bfaaaf 100644
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -1207,7 +1207,7 @@ processChatCommand = \case
     updateGroupProfileByName gName $ \p ->
       p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p}
   QuitChat -> liftIO exitSuccess
-  ShowVersion -> pure $ CRVersionInfo versionNumber
+  ShowVersion -> pure $ CRVersionInfo versionNumber coreVersionInfo
   DebugLocks -> do
     chatLockName <- atomically . tryReadTMVar =<< asks chatLock
     agentLocks <- withAgent debugAgentLocks
diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs
index 8266f49de..3f8bcbf53 100644
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.Controller where
 
@@ -33,6 +34,7 @@ import Data.Time (ZonedTime)
 import Data.Time.Clock (UTCTime)
 import Data.Version (showVersion)
 import GHC.Generics (Generic)
+import GitHash
 import Numeric.Natural
 import qualified Paths_simplex_chat as SC
 import Simplex.Chat.Call
@@ -61,6 +63,19 @@ import UnliftIO.STM
 versionNumber :: String
 versionNumber = showVersion SC.version
 
+coreVersionInfo :: CoreVersionInfo
+coreVersionInfo =
+  CoreVersionInfo
+    { commitHash = giHash gi,
+      commitDate = giCommitDate gi,
+      commitMessage = giCommitMessage gi,
+      branch = giBranch gi,
+      tag = giTag gi,
+      dirty = giDirty gi
+    }
+  where
+    gi = $$tGitInfoCwd
+
 versionStr :: String
 versionStr = "SimpleX Chat v" <> versionNumber
 
@@ -334,7 +349,7 @@ data ChatResponse
   | CRFileTransferStatus (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus
   | CRUserProfile {profile :: Profile}
   | CRUserProfileNoChange
-  | CRVersionInfo {version :: String}
+  | CRVersionInfo {version :: String, coreVersion :: CoreVersionInfo}
   | CRInvitation {connReqInvitation :: ConnReqInvitation}
   | CRSentConfirmation
   | CRSentInvitation {customUserProfile :: Maybe Profile}
@@ -543,6 +558,18 @@ tmeToPref currentTTL tme = uncurry TimedMessagesPreference $ case tme of
   TMEEnableKeepTTL -> (FAYes, currentTTL)
   TMEDisableKeepTTL -> (FANo, currentTTL)
 
+data CoreVersionInfo = CoreVersionInfo
+  { commitHash :: String,
+    commitDate :: String,
+    commitMessage :: String,
+    branch :: String,
+    tag :: String,
+    dirty :: Bool
+  }
+  deriving (Show, Generic)
+
+instance ToJSON CoreVersionInfo where toEncoding = J.genericToEncoding J.defaultOptions
+
 data ChatError
   = ChatError {errorType :: ChatErrorType}
   | ChatErrorAgent {agentError :: AgentErrorType, connectionEntity_ :: Maybe ConnectionEntity}
diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs
index 154d1d8cf..5f0096d67 100644
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -111,7 +111,7 @@ responseToView user_ testView liveItems ts = \case
   CRFileTransferStatus ftStatus -> viewFileTransferStatus ftStatus
   CRUserProfile p -> viewUserProfile p
   CRUserProfileNoChange -> ["user profile did not change"]
-  CRVersionInfo _ -> [plain versionStr, plain updateStr]
+  CRVersionInfo _ info -> [plain versionStr, viewCoreVersionInfo info, plain updateStr]
   CRChatCmdError e -> viewChatError e
   CRInvitation cReq -> viewConnReqInvitation cReq
   CRSentConfirmation -> ["confirmation sent!"]
@@ -1127,6 +1127,10 @@ instance ToJSON WCallCommand where
   toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "WCCall"
   toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "WCCall"
 
+viewCoreVersionInfo :: CoreVersionInfo -> StyledString
+viewCoreVersionInfo CoreVersionInfo {commitHash, commitMessage, commitDate} =
+  plain $ "commit " <> commitHash <> ": " <> commitMessage <> " (" <> commitDate <> ")"
+
 viewChatError :: ChatError -> [StyledString]
 viewChatError = \case
   ChatError err -> case err of