mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
Experimental daml assistant support for metering report [DPP-816] (#12485)
* Add experimental Daml assistant support for ledger metering CHANGELOG_BEGIN Add experimental Daml assistant support for ledger metering CHANGELOG_END * Update with review comments * Update with review comments
This commit is contained in:
parent
9802028380
commit
8fa54c67ce
@ -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"],
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user