feat: fetch ada price from coin-gecko (PLT-4295)

Author: bogdan-manole

nix/materialized/aarch64-darwin/.plan.nix/plutus-certification.nix

@@ -81,6 +81,7 @@
           "Plutus/Certification/TransactionBroadcaster"
           "Plutus/Certification/Server/Internal"
           "Plutus/Certification/Server/Instance"
+          "Plutus/Certification/CoinGeckoClient"
           "Plutus/Certification/API"
           "Plutus/Certification/Cache"
           "Plutus/Certification/Cicero"

nix/materialized/x86_64-darwin/.plan.nix/plutus-certification.nix

@@ -81,6 +81,7 @@
           "Plutus/Certification/TransactionBroadcaster"
           "Plutus/Certification/Server/Internal"
           "Plutus/Certification/Server/Instance"
+          "Plutus/Certification/CoinGeckoClient"
           "Plutus/Certification/API"
           "Plutus/Certification/Cache"
           "Plutus/Certification/Cicero"

nix/materialized/x86_64-linux/.plan.nix/plutus-certification.nix

@@ -81,6 +81,7 @@
           "Plutus/Certification/TransactionBroadcaster"
           "Plutus/Certification/Server/Internal"
           "Plutus/Certification/Server/Instance"
+          "Plutus/Certification/CoinGeckoClient"
           "Plutus/Certification/API"
           "Plutus/Certification/Cache"
           "Plutus/Certification/Cicero"

plutus-certification.cabal

@@ -78,6 +78,7 @@ library
     Plutus.Certification.TransactionBroadcaster
     Plutus.Certification.Server.Internal
     Plutus.Certification.Server.Instance
+    Plutus.Certification.CoinGeckoClient
   autogen-modules: Paths_plutus_certification
   default-language: Haskell2010
 

server/Main.hs

@@ -39,6 +39,7 @@ import Observe.Event.Render.IO.JSON
 import Observe.Event.Wai hiding (OnException)
 import Observe.Event.Servant.Client
 import System.IO
+import Data.IORef
 import Control.Concurrent.MVar
 import Control.Concurrent.Async
 import Network.Wai
@@ -81,7 +82,6 @@ data Args = Args
   , useWhitelist :: !Bool
   , github :: !GitHubArgs
   , bypassSubscriptionValidation :: !Bool
-  , adaUsdPrice :: !DB.AdaUsdPrice
   }
 
 data GitHubArgs = GitHubArgs
@@ -149,11 +149,6 @@ argsParser =  Args
       ( long "unsafe-bypass-subscription-validation"
      <> help "Bypass subscription validation"
       )
-  <*> option auto
-      ( long "ada-usd-price"
-      <> metavar "ADA_USD_PRICE"
-      <> help "price of ADA in USD"
-      )
 
 data AuthMode = JWTAuth JWTArgs | PlainAddressAuth
 
@@ -399,15 +394,20 @@ main = do
       -- if useWhitelist is set to false the whitelist is ignored
       whitelist <- if not args.useWhitelist then pure Nothing else Just <$> whitelisted
       _ <- initDb
-      _ <- forkIO $ startTransactionsMonitor (narrowEventBackend InjectSynchronizer eb) (args.wallet) 10
+      adaPriceRef <- startSynchronizer eb args
       -- TODO: this has to be refactored
       runSettings settings . application (narrowEventBackend InjectServeRequest eb) $
         cors (const $ Just corsPolicy) .
         serveWithContext (Proxy @APIWithSwagger) (genAuthServerContext whitelist args.auth) .
-        (\r -> swaggerSchemaUIServer (documentation args.auth) :<|> server (serverArgs args caps r eb whitelist))
+        (\r -> swaggerSchemaUIServer (documentation args.auth)
+               :<|> server (serverArgs args caps r eb whitelist adaPriceRef))
   exitFailure
   where
-  serverArgs args caps r eb whitelist = ServerArgs
+  startSynchronizer eb args = do
+    ref <- newIORef Nothing
+    _ <- forkIO $ startTransactionsMonitor (narrowEventBackend InjectSynchronizer eb) (args.wallet) ref 10
+    pure ref
+  serverArgs args caps r eb whitelist ref = ServerArgs
     { serverCaps = caps
     , serverWalletArgs  = args.wallet
     , githubToken = args.github.accessToken
@@ -416,8 +416,8 @@ main = do
     , serverSigningTimeout = args.signatureTimeout
     , serverWhitelist = whitelist :: Maybe Whitelist
     , validateSubscriptions = not args.bypassSubscriptionValidation
-    , adaUsdPrice = args.adaUsdPrice
     , serverGitHubCredentials = args.github.credentials
+    , adaUsdPrice = liftIO $ readIORef ref
     }
   jwtArgs PlainAddressAuth = Nothing
   jwtArgs (JWTAuth args) = Just args

src/Plutus/Certification/CoinGeckoClient.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE GADTs              #-}
+
+module Plutus.Certification.CoinGeckoClient where
+
+import Servant.API
+import Servant.Client
+import Data.Functor
+import Data.Fixed
+import Data.Aeson
+
+import Observe.Event.Render.JSON
+import Observe.Event.Backend
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Control.Monad.Catch (MonadMask)
+import Observe.Event
+import Network.HTTP.Client hiding (Proxy)
+
+import Network.HTTP.Client.TLS
+import Data.Proxy
+
+newtype CoinGeckoResponse = CoinGeckoResponse { usdPrice :: Micro } deriving (Show)
+
+type API = "coins"
+         :> Capture "id" String
+         :> QueryParam "tickers" Bool
+         :> QueryParam "market_data" Bool
+         :> QueryParam "community_data" Bool
+         :> QueryParam "developer_data" Bool
+         :> QueryParam "sparkline" Bool
+         :> Get '[JSON] CoinGeckoResponse
+
+-- this is how we access the usd price => .market_data.current_price.usd
+instance FromJSON CoinGeckoResponse where
+  parseJSON = withObject "CoinGeckoResponse" \o ->
+    o  .: "market_data"    >>=
+      (.: "current_price") >>=
+      (.: "usd")           <&>
+      CoinGeckoResponse
+
+data CoinGeckoClientSelector f where
+  FetchAdaPrice :: CoinGeckoClientSelector (Either ClientError Micro)
+
+renderCoinGeckoClientSelector :: RenderSelectorJSON CoinGeckoClientSelector
+renderCoinGeckoClientSelector FetchAdaPrice = ("coin-gecko-fetch-price",\case
+  Left err -> ("http-error",toJSON (show err))
+  Right price -> ("ada-usd-price",toJSON price)
+  )
+
+getAdaPrice :: (MonadIO m,MonadMask m)
+            => EventBackend m r CoinGeckoClientSelector
+            -> m (Either ClientError Micro)
+getAdaPrice eb = withEvent eb FetchAdaPrice $ \ev -> do
+  manager' <- liftIO $ newManager tlsManagerSettings
+  let clientEnv = mkClientEnv manager'
+                  (BaseUrl Https "api.coingecko.com" 443 "api/v3")
+  let clientM = client (Proxy :: Proxy API)
+                  "cardano"
+                  (Just False)                  -- tickers
+                  (Just True)                   -- market_data
+                  (Just False)                  -- community_data
+                  (Just False)                  -- developer_data
+                  (Just False)                  -- sparkline
+
+  resp <- liftIO (runClientM clientM clientEnv) -- extract the usd price
+          <&> fmap usdPrice
+  addField ev resp
+  pure resp

src/Plutus/Certification/Server/Instance.hs

@@ -78,7 +78,7 @@ data ServerArgs m r = ServerArgs
   , serverWhitelist :: !(Maybe Whitelist)
   , serverGitHubCredentials :: !(Maybe GitHubCredentials)
   , validateSubscriptions :: Bool
-  , adaUsdPrice :: DB.AdaUsdPrice
+  , adaUsdPrice :: m (Maybe DB.AdaUsdPrice)
   }
 
 type Whitelist = HashSet Text
@@ -108,7 +108,7 @@ server ServerArgs{..} = NamedAPI
   , versionHead = withEvent eb Version . const $ pure NoContent
   , walletAddress = withEvent eb WalletAddress . const $ pure serverWalletArgs.walletAddress
   , createRun = \(profileId,_) commitOrBranch -> withEvent eb CreateRun \ev -> do
-      -- ensure the profile has an active feauture for L1Run
+      -- ensure the profile has an active feature for L1Run
       validateFeature L1Run profileId
       (fref,profileAccessToken) <- getFlakeRefAndAccessToken profileId commitOrBranch
       let githubToken' =  profileAccessToken <|> githubToken
@@ -276,7 +276,8 @@ server ServerArgs{..} = NamedAPI
     addField ev $ SubscribeFieldProfileId profileId
     addField ev $ SubscribeFieldTierId tierId
     now <- getNow
-    ret <- DB.withDb (DB.createSubscription now profileId tierId adaUsdPrice)
+    adaUsdPrice' <- getAdaUsdPrice'
+    ret <- DB.withDb (DB.createSubscription now profileId tierId adaUsdPrice')
     forM_ ret $ \dto -> addField ev $ SubscribeFieldSubscriptionId (dto.subscriptionDtoId)
     maybeToServerError err404 "Tier not found" ret
 
@@ -295,10 +296,13 @@ server ServerArgs{..} = NamedAPI
     addField ev $ GetActiveFeaturesFieldFeatures featureTypes
     pure featureTypes
   , getAdaUsdPrice = withEvent eb GetAdaUsdPrice \ev -> do
-    addField ev adaUsdPrice
-    pure adaUsdPrice
+    adaUsdPrice' <- getAdaUsdPrice'
+    addField ev adaUsdPrice'
+    pure adaUsdPrice'
   }
   where
+    getAdaUsdPrice' =
+      adaUsdPrice >>= maybeToServerError err500 "Can't get ada usd price"
     validateFeature featureType profileId = do
       -- ensure the profile has an active feauture for L1Run
       when validateSubscriptions $ do

src/Plutus/Certification/Synchronizer.hs

@@ -24,6 +24,7 @@ import Control.Monad.IO.Class ( MonadIO(..) )
 import Control.Monad.Catch (MonadMask)
 import Data.List (groupBy)
 import Plutus.Certification.API.Routes (RunIDV1(..))
+import Plutus.Certification.CoinGeckoClient
 import Data.Aeson
 import Plutus.Certification.TransactionBroadcaster
 import Observe.Event.Render.JSON
@@ -37,15 +38,20 @@ import Control.Monad.Except (MonadError)
 import Data.Maybe (fromMaybe)
 import Observe.Event.Backend
 import Observe.Event
+import Data.IORef
+import Data.Void
+
 data InitializingField
   = WalletArgsField WalletArgs
   | DelayField Int
 
 data SynchronizerSelector f where
   InitializingSynchronizer :: SynchronizerSelector InitializingField
   InjectTxBroadcaster :: forall f . !(TxBroadcasterSelector f) -> SynchronizerSelector f
+  InjectCoinGeckoClient :: forall f . !(CoinGeckoClientSelector f) -> SynchronizerSelector f
   MonitorTransactions :: SynchronizerSelector TransactionsCount
   ActivateSubscriptions :: SynchronizerSelector [DB.SubscriptionId]
+  UpdateAdaPrice :: SynchronizerSelector Void
 
 newtype TransactionsCount = TransactionsCount Int
 
@@ -62,8 +68,10 @@ renderSynchronizerSelector InitializingSynchronizer =
       DelayField delay -> ("delay", toJSON delay)
   )
 renderSynchronizerSelector (InjectTxBroadcaster selector) = renderTxBroadcasterSelector selector
+renderSynchronizerSelector (InjectCoinGeckoClient selector) = renderCoinGeckoClientSelector selector
 renderSynchronizerSelector MonitorTransactions = ("monitor-transactions", renderTransactionsCount)
 renderSynchronizerSelector ActivateSubscriptions = ("activate-subscriptions", renderSubscriptions)
+renderSynchronizerSelector UpdateAdaPrice = ("refresh-ada-price", absurd)
 
 renderSubscriptions :: RenderFieldJSON [DB.SubscriptionId]
 renderSubscriptions subscriptions = ("subscriptions", toJSON subscriptions)
@@ -233,16 +241,31 @@ certifyProfileRuns certificationProcess runs =
 startTransactionsMonitor :: (MonadIO m,MonadMask m,MonadError IOException m)
                          => EventBackend m r SynchronizerSelector
                          -> WalletArgs
+                         -> IORef (Maybe DB.AdaUsdPrice)
                          -> Int
                          -> m b
-startTransactionsMonitor eb args delayInSeconds =
+startTransactionsMonitor eb args adaPriceRef delayInSeconds =
   withEvent eb InitializingSynchronizer $ \ev -> do
     addField ev $ WalletArgsField args
     addField ev $ DelayField delayInSeconds
     -- TODO maybe a forkIO here will be better than into the calling function
     -- hence, now, the parent instrumentation event will never terminate
     forever $ do
+      updateAdaPrice (subEventBackend ev) adaPriceRef
       monitorWalletTransactions (subEventBackend ev) args
       liftIO $ threadDelay delayInMicroseconds
   where
     delayInMicroseconds = delayInSeconds * 1000000
+
+updateAdaPrice :: (MonadIO m,MonadMask m)
+               => EventBackend m r SynchronizerSelector
+               -> IORef (Maybe DB.AdaUsdPrice)
+               -> m ()
+updateAdaPrice eb ref = withEvent eb UpdateAdaPrice $ \_ -> do
+  -- fetch the ada price from the wallet
+  adaPrice <- getAdaPrice ( narrowEventBackend InjectCoinGeckoClient eb )
+  liftIO $ writeIORef ref $
+    case adaPrice of
+     Left _ -> Nothing
+     Right p -> Just p
+