Experimental daml assistant support for metering report [DPP-816]

daml-assistant/daml-helper/BUILD.bazel

@@ -43,6 +43,7 @@ da_haskell_library(
         "uuid",
         "vector",
         "yaml",
+        "aeson-pretty",
     ],
     visibility = ["//visibility:public"],
     deps = [
@@ -68,6 +69,8 @@ da_haskell_binary(
         "process",
         "safe-exceptions",
         "typed-process",
+        "time",
+        "text",
     ],
     main_function = "DA.Daml.Helper.Main.main",
     visibility = ["//visibility:public"],

daml-assistant/daml-helper/src/DA/Daml/Helper/Ledger.hs

@@ -25,16 +25,17 @@ module DA.Daml.Helper.Ledger (
     runLedgerGetDalfs,
     runLedgerListPackages,
     runLedgerListPackages0,
+    runLedgerMeteringReport,
     -- exported for testing
-    downloadAllReachablePackages
+    downloadAllReachablePackages,
     ) where
 
 import Control.Exception (SomeException(..), catch)
 import Control.Applicative ((<|>))
 import Control.Lens (toListOf)
 import Control.Monad.Extra hiding (fromMaybeM)
 import Control.Monad.IO.Class (liftIO)
-import Data.Aeson ((.=))
+import Data.Aeson ((.=), encode)
 import qualified Data.Aeson as A
 import Data.Aeson.Text
 import qualified Data.ByteString as BS
@@ -74,6 +75,9 @@ import qualified DA.Ledger as L
 import qualified DA.Service.Logger as Logger
 import qualified DA.Service.Logger.Impl.IO as Logger
 import qualified SdkVersion
+import DA.Ledger.Types (Timestamp(..), ApplicationId(..), IsoTime(..))
+import Data.Aeson.Encode.Pretty (encodePretty)
+
 
 data LedgerApi
   = Grpc
@@ -651,3 +655,23 @@ sanitizeToken :: String -> String
 sanitizeToken tok
   | "Bearer " `isPrefixOf` tok = tok
   | otherwise = "Bearer " <> tok
+
+-- | Report on Ledger Use.
+runLedgerMeteringReport :: LedgerFlags -> IsoTime -> Maybe IsoTime -> Maybe ApplicationId -> Bool -> IO ()
+runLedgerMeteringReport flags fromIso toIso application compactOutput = do
+    args <- getDefaultArgs flags
+    report <- meteringReport args (L.isoTimeToTimestamp fromIso) (fmap L.isoTimeToTimestamp toIso) application
+    let encodeFn = if compactOutput then encode else encodePretty  
+    let encoded = encodeFn report
+    let bsc = BSL.toStrict encoded
+    let output = BSC.unpack bsc
+    putStrLn output
+
+meteringReport :: LedgerArgs -> Timestamp -> Maybe Timestamp -> Maybe ApplicationId -> IO L.MeteringReport
+meteringReport args from to application =
+  case api args of
+    Grpc -> runWithLedgerArgs args $ do L.getMeteringReport from to application
+    HttpJson -> do
+      hPutStrLn stderr "Error: daml ledger metering can only be run via gRPC at the moment."
+      exitFailure
+

daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs

@@ -16,7 +16,6 @@ import System.IO.Extra
 import System.Process (showCommandForUser)
 import System.Process.Typed (unsafeProcessHandle)
 import Text.Read (readMaybe)
-
 import DA.Signals
 import DA.Daml.Helper.Init
 import DA.Daml.Helper.Ledger
@@ -26,6 +25,8 @@ import DA.Daml.Helper.Studio
 import DA.Daml.Helper.Util
 import DA.Daml.Helper.Codegen
 import DA.PortFile
+import DA.Ledger.Types (ApplicationId(..), IsoTime(..))
+import Data.Text.Lazy (pack)
 
 main :: IO ()
 main = do
@@ -71,6 +72,7 @@ data Command
     | LedgerNavigator { flags :: LedgerFlags, remainingArguments :: [String] }
     | Codegen { lang :: Lang, remainingArguments :: [String] }
     | PackagesList {flags :: LedgerFlags}
+    | LedgerMeteringReport { flags :: LedgerFlags, from :: IsoTime, to :: Maybe IsoTime, application :: Maybe ApplicationId, compactOutput :: Bool }
     | CantonSandbox
         { cantonOptions :: CantonOptions
         , portFileM :: Maybe FilePath
@@ -261,6 +263,9 @@ commandParser = subparser $ fold
             , command "navigator" $ info
                 (ledgerNavigatorCmd <**> helper)
                 (forwardOptions <> progDesc "Launch Navigator on ledger")
+            , command "metering-report" $ info
+                (ledgerMeteringReportCmd <**> helper)
+                (forwardOptions <> progDesc "Report on Ledger Use")                
             ]
         , subparser $ internal <> fold -- hidden subcommands
             [ command "allocate-party" $ info
@@ -335,6 +340,16 @@ commandParser = subparser $ fold
         <$> ledgerFlags (ShowJsonApi False)
         <*> many (argument str (metavar "ARG" <> help "Extra arguments to navigator."))
 
+    app :: ReadM ApplicationId
+    app = fmap (ApplicationId . pack) str
+
+    ledgerMeteringReportCmd = LedgerMeteringReport
+        <$> ledgerFlags (ShowJsonApi True)
+        <*> option auto (long "from" <> metavar "FROM" <> help "From date of report (inclusive).")
+        <*> optional (option auto (long "to" <> metavar "TO" <> help "To date of report (exclusive)."))
+        <*> optional (option app (long "application" <> metavar "APP" <> help "Report application identifier."))
+        <*> switch (long "compact-output" <> help "Generate compact report.")
+
     ledgerFlags showJsonApi = LedgerFlags
         <$> httpJsonFlag showJsonApi
         <*> sslConfig
@@ -470,6 +485,7 @@ runCommand = \case
     LedgerExport {..} -> runLedgerExport flags remainingArguments
     LedgerNavigator {..} -> runLedgerNavigator flags remainingArguments
     Codegen {..} -> runCodegen lang remainingArguments
+    LedgerMeteringReport {..} -> runLedgerMeteringReport flags from to application compactOutput
     CantonSandbox {..} ->
         withCantonPortFile cantonOptions $ \cantonOptions cantonPortFile ->
             withCantonSandbox cantonOptions remainingArguments $ \ph -> do

language-support/hs/bindings/src/DA/Ledger/Convert.hs

@@ -17,7 +17,9 @@ module DA.Ledger.Convert (
     raiseGetTimeResponse,
     raiseTimestamp,
     raisePackageId,
-    RaiseFailureReason,
+    raiseApplicationId,
+    raiseParticipantId,
+    RaiseFailureReason(..),
     ) where
 
 import Prelude hiding(Enum)
@@ -485,6 +487,12 @@ raiseChoice = fmap Choice . raiseText "Choice"
 raiseParty :: Text -> Perhaps Party
 raiseParty = fmap Party . raiseText "Party"
 
+raiseApplicationId :: Text -> Perhaps ApplicationId
+raiseApplicationId = fmap ApplicationId . raiseText "ApplicationId"
+
+raiseParticipantId :: Text -> Perhaps ParticipantId
+raiseParticipantId = fmap ParticipantId . raiseText "ParticipantId"
+
 raisePackageId :: Text -> Perhaps PackageId
 raisePackageId = fmap PackageId . raiseText "PackageId"
 

language-support/hs/bindings/src/DA/Ledger/Services.hs

@@ -14,3 +14,4 @@ import DA.Ledger.Services.PartyManagementService as X
 import DA.Ledger.Services.PackageService as X
 import DA.Ledger.Services.TimeService as X
 import DA.Ledger.Services.TransactionService as X
+import DA.Ledger.Services.MeteringReportService as X

language-support/hs/bindings/src/DA/Ledger/Services/MeteringReportService.hs

@@ -0,0 +1,116 @@
+-- Copyright (c) 2022 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module DA.Ledger.Services.MeteringReportService (
+    getMeteringReport, 
+    MeteringReport(..), 
+    isoTimeToTimestamp,
+  ) where
+
+
+import Data.Aeson ( KeyValue((.=)), ToJSON(..), object)
+import DA.Ledger.Convert
+import DA.Ledger.GrpcWrapUtils
+import DA.Ledger.LedgerService
+import DA.Ledger.Types
+import qualified Data.Text.Lazy as TL
+import Network.GRPC.HighLevel.Generated
+import qualified Com.Daml.Ledger.Api.V1.Admin.MeteringReportService as LL
+import Data.Maybe (maybeToList)
+import qualified Data.Time.Clock.System as System
+import qualified Data.Time.Format.ISO8601 as ISO8601
+import GHC.Int (Int64)
+import GHC.Word (Word32)
+
+data MeteredApplication = MeteredApplication {
+  application :: ApplicationId
+, events :: Int64
+} deriving (Show)
+
+instance ToJSON MeteredApplication where
+  toJSON (MeteredApplication application events) =
+    object
+    [   "application" .= unApplicationId application
+    ,   "events" .= events
+    ]
+
+data MeteringReport = MeteringReport {
+  participant :: ParticipantId
+, from  :: Timestamp
+, toRequested :: Maybe Timestamp
+, toActual :: Timestamp
+, applications :: [MeteredApplication]
+} deriving (Show)
+
+instance ToJSON MeteringReport where
+  toJSON (MeteringReport participant from toRequested toActual applications) =
+    object (
+    [   "participant" .= unParticipantId participant
+    ,   "from" .= timestampToIso8601 from
+    ,   "toActual" .= timestampToIso8601 toActual
+    ,   "applications" .= applications
+    ]
+    ++ maybeToList (fmap (("toRequested" .=) . timestampToIso8601) toRequested)
+    )
+
+timestampToSystemTime :: Timestamp -> System.SystemTime
+timestampToSystemTime ts = st
+  where
+    s = fromIntegral (seconds ts) :: Int64
+    n = fromIntegral (nanos ts) :: Word32
+    st = System.MkSystemTime s n
+
+systemTimeToTimestamp :: System.SystemTime -> Timestamp
+systemTimeToTimestamp st = ts
+  where
+    s = fromIntegral (System.systemSeconds st) :: Int
+    n = fromIntegral (System.systemNanoseconds st) :: Int
+    ts = Timestamp s n
+
+timestampToIso8601 :: Timestamp -> String
+timestampToIso8601 ts = ISO8601.iso8601Show ut
+  where
+    st = timestampToSystemTime ts
+    ut = System.systemToUTCTime st
+
+isoTimeToTimestamp :: IsoTime -> Timestamp
+isoTimeToTimestamp iso = systemTimeToTimestamp $ System.utcToSystemTime $ unIsoTime iso
+
+raiseApplicationMeteringReport :: LL.ApplicationMeteringReport -> Perhaps MeteredApplication
+raiseApplicationMeteringReport (LL.ApplicationMeteringReport llApp events) = do
+  application <- raiseApplicationId llApp
+  return MeteredApplication {..}
+
+raiseParticipantMeteringReport ::  LL.GetMeteringReportRequest ->  LL.ParticipantMeteringReport -> Perhaps MeteringReport
+raiseParticipantMeteringReport (LL.GetMeteringReportRequest (Just llFrom) llTo _)  (LL.ParticipantMeteringReport llParticipantId (Just llToActual) llAppReports) = do
+  participant <- raiseParticipantId llParticipantId
+  from <- raiseTimestamp llFrom
+  toRequested <- traverse raiseTimestamp llTo
+  toActual <- raiseTimestamp llToActual
+  applications <- raiseList raiseApplicationMeteringReport llAppReports
+  return MeteringReport{..}
+
+raiseParticipantMeteringReport _ response = Left $ Unexpected ("raiseParticipantMeteringReport unable to parse response: " <> show response)
+
+raiseGetMeteringReportResponse :: LL.GetMeteringReportResponse -> Perhaps MeteringReport
+raiseGetMeteringReportResponse (LL.GetMeteringReportResponse (Just request) (Just report) (Just _)) = 
+  raiseParticipantMeteringReport request report
+
+raiseGetMeteringReportResponse response = Left $ Unexpected ("raiseMeteredReport unable to parse response: " <> show response)
+
+getMeteringReport :: Timestamp -> Maybe Timestamp -> Maybe ApplicationId -> LedgerService MeteringReport
+getMeteringReport from to applicationId =
+    makeLedgerService $ \timeout config mdm ->
+    withGRPCClient config $ \client -> do
+        service <- LL.meteringReportServiceClient client
+        let
+          LL.MeteringReportService {meteringReportServiceGetMeteringReport=rpc} = service
+          gFrom = Just $ lowerTimestamp from
+          gTo = fmap lowerTimestamp to
+          gApp = maybe TL.empty unApplicationId applicationId
+          request = LL.GetMeteringReportRequest gFrom gTo gApp
+        rpc (ClientNormalRequest request timeout mdm)
+            >>= unwrap
+            >>= either (fail . show) return . raiseGetMeteringReportResponse

language-support/hs/bindings/src/DA/Ledger/Services/PartyManagementService.hs

@@ -20,8 +20,6 @@ import qualified Data.Aeson as A
 import Data.Aeson ((.:))
 import qualified Com.Daml.Ledger.Api.V1.Admin.PartyManagementService as LL
 
-newtype ParticipantId = ParticipantId { unParticipantId :: Text} deriving (Eq,Ord,Show)
-
 getParticipantId :: LedgerService ParticipantId
 getParticipantId =
     makeLedgerService $ \timeout config mdm -> do

language-support/hs/bindings/src/DA/Ledger/Types.hs

@@ -55,7 +55,9 @@ module DA.Ledger.Types( -- High Level types for communication over Ledger API
     SubmissionId(..),
     LL.Duration(..),
     LL.Status(..),
-    DeduplicationPeriod(..)
+    DeduplicationPeriod(..),
+    ParticipantId(..),
+    IsoTime(..),
     ) where
 
 import qualified Data.Aeson as A
@@ -67,6 +69,9 @@ import Prelude hiding(Enum)
 import qualified Data.Text.Lazy as Text(unpack)
 import qualified Google.Protobuf.Duration as LL
 import qualified Google.Rpc.Status as LL
+import qualified Data.Time.Format.ISO8601 as ISO8601
+import qualified Data.Time.Clock as Clock
+import qualified Text.ParserCombinators.ReadP as ReadP
 
 -- commands.proto
 
@@ -272,6 +277,7 @@ newtype DaysSinceEpoch = DaysSinceEpoch { unDaysSinceEpoch :: Int}
 newtype TemplateId = TemplateId Identifier deriving (Eq,Ord,Show)
 
 newtype ApplicationId = ApplicationId { unApplicationId :: Text } deriving (Eq,Ord,Show)
+newtype ParticipantId = ParticipantId { unParticipantId :: Text} deriving (Eq,Ord,Show)
 newtype CommandId = CommandId { unCommandId :: Text } deriving (Eq,Ord,Show)
 newtype ConstructorId = ConstructorId { unConstructorId :: Text } deriving (Eq,Ord,Show)
 newtype ContractId = ContractId { unContractId :: Text } deriving (Eq,Ord,Show)
@@ -294,3 +300,10 @@ instance A.FromJSON Party where
   parseJSON v = Party <$> A.parseJSON v
 
 newtype Verbosity = Verbosity { unVerbosity :: Bool } deriving (Eq,Ord,Show)
+
+-- A wrapped UTCTime the can be read in ISO8601 format
+newtype IsoTime = IsoTime { unIsoTime :: Clock.UTCTime } deriving Show
+
+instance Read IsoTime where
+  readsPrec _ = ReadP.readP_to_S $ fmap IsoTime $ ISO8601.formatReadP ISO8601.iso8601Format
+

language-support/hs/bindings/test/DA/Ledger/Tests.hs

@@ -77,6 +77,7 @@ sharedSandboxTests testDar = testGroupWithSandbox testDar Nothing "shared sandbo
     , tUploadDarFileBad
     , tUploadDarFileGood
     , tAllocateParty
+    , tMeteringReport
     ]
 
 authenticatingSandboxTests :: FilePath -> TestTree
@@ -543,6 +544,13 @@ tValueConversion withSandbox = testCase "tValueConversion" $ run withSandbox $ \
     [RecordField{label="owner"},RecordField{label="bucket",fieldValue=bucketReturned}] <- return fields
     liftIO $ assertEqual "bucket" bucket (detag bucketReturned)
 
+tMeteringReport :: SandboxTest
+tMeteringReport withSandbox = testCase "tMeteringReport" $ run withSandbox $ \_ _testId -> do
+    let expected = Timestamp {seconds = 1, nanos = 2}
+    report <- getMeteringReport expected Nothing Nothing
+    let MeteringReport{from=actual} = report
+    liftIO $ assertEqual "report from date" expected actual
+
 -- Strip the rid,vid,eid tags recusively from record, variant and enum values
 detag :: Value -> Value
 detag = \case