version command

commit 9df07ae34a6d1c7f53cee3abe2304ff81eb0a26c Author: Sergey Ivanov <ivanovs-4@yandex.ru> Date: Tue Oct 24 22:25:34 2023 +0400 `version` command for hbs2, hbs2-peer, git-hbs2
2024-01-28 07:51:46 +03:00 · 2024-01-28 07:51:46 +03:00 · e6ae5fb593
parent 889947bf51
commit e6ae5fb593
9 changed files with 117 additions and 21 deletions
--- a/flake.nix
+++ b/flake.nix
@ -26,7 +26,18 @@ inputs = {
 };

 outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
-
+  let
+    packageNames = [
+     "hbs2"
+     "hbs2-peer"
+     "hbs2-core"
+     "hbs2-storage-simple"
+     "hbs2-git"
+     "hbs2-qblf"
+     "hbs2-keyman"
+     "hbs2-share"
+    ];
+  in
 haskell-flake-utils.lib.simpleCabalProject2flake {
   inherit self nixpkgs;
   systems = [ "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ];
@ -37,16 +48,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
     db-pipe
   ];

-   packageNames = [
-     "hbs2"
-     "hbs2-peer"
-     "hbs2-core"
-     "hbs2-storage-simple"
-     "hbs2-git"
-     "hbs2-qblf"
-     "hbs2-keyman"
-     "hbs2-share"
-   ];
+   inherit packageNames;

   packageDirs = {
     "hbs2" = "./hbs2";
@ -75,16 +77,38 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
    justStaticExecutables

    dontCheck
+
+    (compose.overrideCabal (drv: {
+        preBuild = ''
+          export GIT_HASH="${self.rev or self.dirtyRev or "dirty"}"
+        '';
+      }))
+
   ];

-   shellExtBuildInputs = {pkgs}: with pkgs;  [
-     haskellPackages.haskell-language-server
-     haskellPackages.htags
-     haskellPackages.hoogle
-     pkg-config
-     inputs.hspup.packages.${pkgs.system}.default
-     inputs.fixme.packages.${pkgs.system}.default
-   ];
+   shell = {pkgs, ...}:
+      pkgs.haskellPackages.shellFor {
+        packages = _: pkgs.lib.attrsets.attrVals packageNames pkgs.haskellPackages;
+        # withHoogle = true;
+        buildInputs = (
+          with pkgs.haskellPackages; ([
+            ghcid
+            cabal-install
+            haskell-language-server
+            htags
+          ])
+          ++
+          [ pkgs.pkg-config
+            inputs.hspup.packages.${pkgs.system}.default
+            inputs.fixme.packages.${pkgs.system}.default
+          ]
+        );
+
+        shellHook = ''
+          export GIT_HASH="${self.rev or self.dirtyRev or "dirty"}"
+        '';
+
+      };

 };

--- a/hbs2-core/hbs2-core.cabal
+++ b/hbs2-core/hbs2-core.cabal
@ -147,6 +147,7 @@ library
                    , HBS2.Net.Dialog.Client
                    , HBS2.Net.Dialog.Helpers.List
                    , HBS2.Net.Dialog.Helpers.Streaming
+                    , HBS2.Version


    -- other-modules:
@ -205,6 +206,7 @@ library
                    , streaming
                    , string-conversions
                    , suckless-conf
+                    , template-haskell
                    , temporary
                    , text
                    , time
--- a/hbs2-core/lib/HBS2/Version.hs
+++ b/hbs2-core/lib/HBS2/Version.hs
@ -0,0 +1,39 @@
+{-# LANGUAGE StrictData #-}
+
+module HBS2.Version (inlineBuildVersion, BuildVersion(..)) where
+
+import Data.Aeson
+import Data.Data
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Version (Version, showVersion)
+import GHC.Generics
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift (..), dataToExpQ)
+import System.Environment (getEnvironment)
+
+data BuildVersion = BuildVersion
+    { buildVersion_git :: Maybe Text
+    , buildVersion_pkg :: Text
+    }
+    deriving (Generic, Eq, Show, Data)
+
+instance ToJSON BuildVersion
+
+-- | Lift text as expression in TH.
+-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
+liftText :: Text -> Q Exp
+liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt)
+
+liftDataWithText :: (Data a) => a -> Q Exp
+liftDataWithText = dataToExpQ (fmap liftText . cast)
+
+lookupEnv :: String -> Q (Maybe Text)
+lookupEnv key = fmap (T.strip . T.pack) . lookup key <$> runIO getEnvironment
+
+inlineBuildVersion :: Version -> Q Exp
+inlineBuildVersion version =
+    flip sigE [t|BuildVersion|] . liftDataWithText =<< do
+        buildVersion_git <- lookupEnv "GIT_HASH"
+        let buildVersion_pkg = (T.pack . showVersion) version
+        pure BuildVersion {..}
--- a/hbs2-git/git-hbs2/Main.hs
+++ b/hbs2-git/git-hbs2/Main.hs
@ -8,11 +8,16 @@ import HBS2Git.Export
 import HBS2Git.Tools
 import HBS2Git.KeysCommand
 import HBS2.Net.Proto.Definition()
+import HBS2.Version

 import RunShow

 import Options.Applicative as O
 import Control.Monad
+import Data.Aeson qualified as Aeson
+import Data.ByteString.Lazy qualified as LBS
+
+import Paths_hbs2_git qualified as Pkg

 main :: IO ()
 main = join . customExecParser (prefs showHelpOnError) $
@ -28,8 +33,12 @@ main = join . customExecParser (prefs showHelpOnError) $
                        <> command "show"      (info pShow (progDesc "show various types of objects"))
                        <> command "tools"     (info pTools (progDesc "misc tools"))
                        <> command "key"       (info pKeys (progDesc "manage keys"))
+                        <> command "version"   (info pVersion (progDesc "show program version"))
                        )

+    pVersion = pure do
+        LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version)
+
    pExport = do
      keyfile   <- strArgument (metavar "KEIRING-FILE")
      pure $ runApp WithLog do
--- a/hbs2-git/hbs2-git.cabal
+++ b/hbs2-git/hbs2-git.cabal
@ -53,6 +53,7 @@ common shared-properties
                     , TypeApplications
                     , TypeOperators
                     , TypeFamilies
+                     , TemplateHaskell


  build-depends: hbs2-core, hbs2-peer
@ -148,12 +149,14 @@ executable git-hbs2

    other-modules:
      RunShow
+      Paths_hbs2_git

    -- other-extensions:
    build-depends:
        base, hbs2-git
      , optparse-applicative
      , http-types
+      , template-haskell

    hs-source-dirs:   git-hbs2
    default-language: Haskell2010
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@ -39,6 +39,8 @@ import HBS2.Storage.Operations.Missed
 import HBS2.Data.Detect

 import HBS2.System.Logger.Simple hiding (info)
+import HBS2.Version
+import Paths_hbs2_peer qualified as Pkg

 import Brains
 import BrainyPeerLocator
@ -84,6 +86,7 @@ import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Writer.CPS qualified as W
 import Crypto.Saltine (sodiumInit)
+import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
 import Data.Cache qualified as Cache
@ -240,6 +243,7 @@ runCLI = do
                <> command "poll"      (info pPoll  (progDesc "polling management"))
                <> command "log"       (info pLog   (progDesc "set logging level"))
                <> command "bypass"    (info pByPass (progDesc "bypass"))
+                <> command "version"   (info pVersion (progDesc "show program version"))
                -- FIXME: bring-back-dialogue-over-separate-socket
                -- <> command "dial"      (info pDialog (progDesc "dialog commands"))
                )
@ -272,6 +276,9 @@ runCLI = do

      m

+    pVersion = pure do
+        LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version)
+
    pRun = do
      runPeer <$> common

--- a/hbs2-peer/hbs2-peer.cabal
+++ b/hbs2-peer/hbs2-peer.cabal
@ -75,6 +75,7 @@ common common-deps
        , heaps
        , psqueues
        , string-conversions
+        , template-haskell

 common shared-properties
  ghc-options:
@ -119,6 +120,7 @@ common shared-properties
                     , RecursiveDo
                     , ScopedTypeVariables
                     , StandaloneDeriving
+                     , TemplateHaskell
                     , TupleSections
                     , TypeApplications
                     , TypeFamilies
@ -197,6 +199,8 @@ executable hbs2-peer
                    , CLI.Common
                    , CLI.RefChan

+                    , Paths_hbs2_peer
+
    -- other-extensions:
    build-depends:    base, hbs2-peer, hbs2-keyman, vty

--- a/hbs2/Main.hs
+++ b/hbs2/Main.hs
@ -24,6 +24,8 @@ import HBS2.Storage.Simple
 import HBS2.Storage.Simple.Extra
 import HBS2.Data.Bundle
 import HBS2.OrDie
+import HBS2.Version
+import Paths_hbs2 qualified as Pkg


 import HBS2.System.Logger.Simple hiding (info)
@ -38,6 +40,7 @@ import Control.Monad.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Resource
 import Crypto.Saltine.Core.Box qualified as Encrypt
+import Data.Aeson qualified as Aeson
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy qualified as LBS
@ -548,12 +551,15 @@ main = join . customExecParser (prefs showHelpOnError) $
                        <> command "reflog"          (info pReflog (progDesc "reflog commands"))
                        <> command "bundle"          (info pBundle (progDesc "bundle commands"))
                        <> command "anyref"          (info pAnyRef (progDesc "anyref commands"))
+                        <> command "version"         (info pVersion (progDesc "show program version"))
                        )
-
    common = do
      pref <- optional $ strOption ( short 'p' <> long "prefix" <> help "storage prefix" )
      pure $ CommonOpts pref

+    pVersion = pure do
+        LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version)
+
    pStore = do
      o <- common
      file <- optional $ strArgument ( metavar "FILE" )
--- a/hbs2/hbs2.cabal
+++ b/hbs2/hbs2.cabal
@ -52,6 +52,7 @@ common shared-properties
                     , RecordWildCards
                     , ScopedTypeVariables
                     , StandaloneDeriving
+                     , TemplateHaskell
                     , TupleSections
                     , TypeApplications
                     , TypeFamilies
@ -60,7 +61,8 @@ common shared-properties
 executable hbs2
    import:           shared-properties
    main-is:          Main.hs
-    -- other-modules:
+    other-modules:
+      Paths_hbs2
    -- other-extensions:
    build-depends:    base, hbs2-core, hbs2-storage-simple
                    , aeson