feat(#85): add taptools /prices route

.github/workflows/haskell.yml

@@ -57,7 +57,7 @@ jobs:
       uses: haskell-actions/setup@v2
       with:
         ghc-version: '9.6.5'
-        cabal-version: '3.10.1.0'
+        cabal-version: '3.12.1.0'
         enable-stack: true
         stack-version: '2.9'
     - name: Setup cache

Dockerfile

@@ -81,7 +81,7 @@ RUN gpg --batch --keyserver keyserver.ubuntu.com --recv-keys 7D1E8AFD1D4A16D71FA
 # ghcup:
 ENV BOOTSTRAP_HASKELL_NONINTERACTIVE=1
 ENV BOOTSTRAP_HASKELL_GHC_VERSION=9.6.5
-ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.10.2.0
+ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.12.1.0
 RUN bash -c "curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh"
 ENV PATH=${PATH}:/root/.local/bin
 ENV PATH=${PATH}:/root/.ghcup/bin

geniusyield-server-lib/CHANGELOG.md

@@ -1,5 +1,10 @@
 # Revision history for geniusyield-server-lib
 
+## 0.11.1 -- 2024-10-30
+
+* Adds support of [`prices`](https://openapi.taptools.io/#tag/Market-Tokens/paths/~1token~1prices/post) TapTools endpoint.
+* In case project is being built from an environment which lacks access to corresponding `.git` directory, "UNKNOWN_REVISION" is used for `revision` field when querying for settings of the server.
+
 ## 0.11.0 -- 2024-08-30
 
 * Update to Atlas v0.6.0.

geniusyield-server-lib/geniusyield-server-lib.cabal

@@ -1,6 +1,6 @@
-cabal-version:   3.6
+cabal-version:   3.12
 name:            geniusyield-server-lib
-version:         0.11.0
+version:         0.11.1
 synopsis:        GeniusYield server library
 description:     Library for GeniusYield server.
 license:         Apache-2.0
@@ -85,6 +85,7 @@ library
     , binary
     , bytestring
     , cardano-api
+    , containers
     , deriving-aeson
     , envy
     , fast-logger

geniusyield-server-lib/src/GeniusYield/Server/Constants.hs

@@ -9,4 +9,4 @@ import RIO
 
 -- | The git hash of the current commit.
 gitHash ∷ String
-gitHash = $$tGitInfoCwd & giHash
+gitHash = either (const "UNKNOWN_REVISION") giHash $$tGitInfoCwdTry

geniusyield-server-lib/src/GeniusYield/Server/Dex/HistoricalPrices/TapTools/Client.hs

@@ -6,20 +6,25 @@ module GeniusYield.Server.Dex.HistoricalPrices.TapTools.Client (
   TapToolsOHLCVAPI,
   tapToolsClientEnv,
   tapToolsOHLCV,
+  tapToolsPrices,
+  PricesResponse,
   TapToolsException,
   handleTapToolsError,
 ) where
 
 import Control.Lens ((?~))
 import Data.Aeson (ToJSON (..))
+import Data.Aeson qualified as Aeson
+import Data.Aeson.Types qualified as Aeson
+import Data.Map.Strict qualified as Map
 import Data.Swagger qualified as Swagger
 import Data.Time.Clock.POSIX
 import Deriving.Aeson
 import GHC.TypeLits (Symbol, symbolVal)
 import GeniusYield.Server.Ctx (TapToolsApiKey, TapToolsEnv (tteApiKey, tteClientEnv))
 import GeniusYield.Server.Utils (commonEnumParamSchemaRecipe, hideServantClientErrorHeader)
 import GeniusYield.Swagger.Utils
-import GeniusYield.Types (GYAssetClass)
+import GeniusYield.Types (GYAssetClass, makeAssetClass)
 import Maestro.Types.Common (LowerFirst)
 import Network.HTTP.Client (newManager)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
@@ -47,6 +52,25 @@ instance ToHttpApiData TapToolsUnit where
    where
     removeDot = Text.filter (/= '.')
 
+instance Aeson.ToJSON TapToolsUnit where
+  toJSON = Aeson.toJSON . toUrlPiece
+
+instance Aeson.ToJSONKey TapToolsUnit where
+  toJSONKey = Aeson.toJSONKeyText toUrlPiece
+
+instance FromHttpApiData TapToolsUnit where
+  parseUrlPiece t =
+    let (pid, tn) = Text.splitAt 56 t
+     in bimap Text.pack TapToolsUnit $ makeAssetClass pid tn
+
+instance Aeson.FromJSON TapToolsUnit where
+  parseJSON = Aeson.withText "TapToolsUnit" $ \t → case parseUrlPiece t of
+    Left e → fail $ show e
+    Right ttu → pure ttu
+
+instance Aeson.FromJSONKey TapToolsUnit where
+  fromJSONKey = Aeson.FromJSONKeyTextParser (either (fail . show) pure . parseUrlPiece)
+
 data TapToolsInterval = TTI3m | TTI5m | TTI15m | TTI30m | TTI1h | TTI2h | TTI4h | TTI12h | TTI1d | TTI3d | TTI1w | TTI1M
   deriving stock (Eq, Ord, Enum, Bounded, Data, Typeable, Generic)
   deriving (FromJSON, ToJSON) via CustomJSON '[ConstructorTagModifier '[StripPrefix "TTI"]] TapToolsInterval
@@ -111,22 +135,34 @@ instance Swagger.ToSchema TapToolsOHLCV where
           & addSwaggerDescription "Get a specific token's trended (open, high, low, close, volume) price data."
           & addSwaggerExample (toJSON $ TapToolsOHLCV {tapToolsOHLCVTime = 1_715_007_300, tapToolsOHLCVOpen = open, tapToolsOHLCVHigh = open, tapToolsOHLCVLow = open, tapToolsOHLCVClose = open, tapToolsOHLCVVolume = 120})
 
+type PricesResponse = Map.Map TapToolsUnit Double
+
 type TapToolsApiKeyHeaderName ∷ Symbol
 type TapToolsApiKeyHeaderName = "x-api-key"
 
 type TapToolsAPI =
-  Header' '[Required] TapToolsApiKeyHeaderName TapToolsApiKey :> TapToolsOHLCVAPI
+  Header' '[Required] TapToolsApiKeyHeaderName TapToolsApiKey
+    :> "token"
+    :> (TapToolsOHLCVAPI :<|> TapToolsPricesAPI)
 
 type TapToolsOHLCVAPI =
-  "token"
-    :> "ohlcv"
+  "ohlcv"
     :> QueryParam "unit" TapToolsUnit
     :> QueryParam' '[Required, Strict] "interval" TapToolsInterval
     :> QueryParam "numIntervals" Natural
     :> Get '[JSON] [TapToolsOHLCV]
 
-_tapToolsOHLCV ∷ TapToolsApiKey → Maybe TapToolsUnit → TapToolsInterval → Maybe Natural → ClientM [TapToolsOHLCV]
-_tapToolsOHLCV = client (Proxy @TapToolsAPI)
+type TapToolsPricesAPI = "prices" :> ReqBody '[JSON] [TapToolsUnit] :> Post '[JSON] PricesResponse
+
+data TapToolsClient = TapToolsClient
+  { tapToolsOHLCVClient ∷ Maybe TapToolsUnit → TapToolsInterval → Maybe Natural → ClientM [TapToolsOHLCV],
+    tapToolsPricesClient ∷ [TapToolsUnit] → ClientM PricesResponse
+  }
+
+mkTapToolsClient ∷ TapToolsApiKey → TapToolsClient
+mkTapToolsClient apiKey =
+  let tapToolsOHLCVClient :<|> tapToolsPricesClient = client (Proxy @TapToolsAPI) apiKey
+   in TapToolsClient {..}
 
 tapToolsBaseUrl ∷ String
 tapToolsBaseUrl = "https://openapi.taptools.io/api/v1"
@@ -151,4 +187,7 @@ handleTapToolsError ∷ Text → Either ClientError a → IO a
 handleTapToolsError locationInfo = either (throwIO . TapToolsApiError locationInfo . hideServantClientErrorHeader (fromString $ symbolVal (Proxy @TapToolsApiKeyHeaderName))) pure
 
 tapToolsOHLCV ∷ TapToolsEnv → Maybe TapToolsUnit → TapToolsInterval → Maybe Natural → IO [TapToolsOHLCV]
-tapToolsOHLCV env@(tteApiKey → apiKey) ttu tti mttni = _tapToolsOHLCV apiKey ttu tti mttni & runTapToolsClient env >>= handleTapToolsError "tapToolsOHLCV"
+tapToolsOHLCV env@(tteApiKey → apiKey) ttu tti mttni = mkTapToolsClient apiKey & tapToolsOHLCVClient & (\f → f ttu tti mttni) & runTapToolsClient env >>= handleTapToolsError "tapToolsOHLCV"
+
+tapToolsPrices ∷ TapToolsEnv → [TapToolsUnit] → IO PricesResponse
+tapToolsPrices env@(tteApiKey → apiKey) ttus = mkTapToolsClient apiKey & tapToolsPricesClient & (\f → f ttus) & runTapToolsClient env >>= handleTapToolsError "tapToolsPrices"