diff --git a/daml-assistant/daml-helper/BUILD.bazel b/daml-assistant/daml-helper/BUILD.bazel index d3712f8949..dd4d2d642e 100644 --- a/daml-assistant/daml-helper/BUILD.bazel +++ b/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"], diff --git a/daml-assistant/daml-helper/src/DA/Daml/Helper/Ledger.hs b/daml-assistant/daml-helper/src/DA/Daml/Helper/Ledger.hs index ff0c6a6da5..8cdbe01f77 100644 --- a/daml-assistant/daml-helper/src/DA/Daml/Helper/Ledger.hs +++ b/daml-assistant/daml-helper/src/DA/Daml/Helper/Ledger.hs @@ -25,8 +25,9 @@ module DA.Daml.Helper.Ledger ( runLedgerGetDalfs, runLedgerListPackages, runLedgerListPackages0, + runLedgerMeteringReport, -- exported for testing - downloadAllReachablePackages + downloadAllReachablePackages, ) where import Control.Exception (SomeException(..), catch) @@ -34,7 +35,7 @@ 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 + diff --git a/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs b/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs index d8cd841078..9da42404e5 100644 --- a/daml-assistant/daml-helper/src/DA/Daml/Helper/Main.hs +++ b/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 diff --git a/language-support/hs/bindings/src/DA/Ledger/Convert.hs b/language-support/hs/bindings/src/DA/Ledger/Convert.hs index 3c606173bb..05f97bff4a 100644 --- a/language-support/hs/bindings/src/DA/Ledger/Convert.hs +++ b/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" diff --git a/language-support/hs/bindings/src/DA/Ledger/Services.hs b/language-support/hs/bindings/src/DA/Ledger/Services.hs index d3133147ca..4b7919f0ba 100644 --- a/language-support/hs/bindings/src/DA/Ledger/Services.hs +++ b/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 diff --git a/language-support/hs/bindings/src/DA/Ledger/Services/MeteringReportService.hs b/language-support/hs/bindings/src/DA/Ledger/Services/MeteringReportService.hs new file mode 100644 index 0000000000..8dd5febbe0 --- /dev/null +++ b/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 diff --git a/language-support/hs/bindings/src/DA/Ledger/Services/PartyManagementService.hs b/language-support/hs/bindings/src/DA/Ledger/Services/PartyManagementService.hs index b6c54ed491..051fb0db82 100644 --- a/language-support/hs/bindings/src/DA/Ledger/Services/PartyManagementService.hs +++ b/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 diff --git a/language-support/hs/bindings/src/DA/Ledger/Types.hs b/language-support/hs/bindings/src/DA/Ledger/Types.hs index 580761a51c..4fbbdc25e8 100644 --- a/language-support/hs/bindings/src/DA/Ledger/Types.hs +++ b/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 + diff --git a/language-support/hs/bindings/test/DA/Ledger/Tests.hs b/language-support/hs/bindings/test/DA/Ledger/Tests.hs index 7467dd1fc6..68140df185 100644 --- a/language-support/hs/bindings/test/DA/Ledger/Tests.hs +++ b/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