Crypto.hs

{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.Crypto
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides utility functions for retrieving data about crypto
-- assets.
-----------------------------------------------------------------------------
module System.Taffybar.Information.Crypto where

import           Control.Concurrent
import           Control.Concurrent.STM.TChan
import           Control.Exception.Enclosed (catchAny)
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.STM (atomically)
import           Data.Aeson
import           Data.Aeson.Types (parseMaybe)
import qualified Data.Aeson.Key as Key
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.UTF8 as BS
import qualified Data.Map as M
import           Data.Maybe
import           Data.Proxy
import           Data.Text (Text)
import qualified Data.Text as T
import           GHC.TypeLits
import           Network.HTTP.Simple hiding (Proxy)
import           System.Log.Logger
import           System.Taffybar.Context
import           System.Taffybar.Util
import           Text.Printf

getSymbolToCoinGeckoId :: MonadIO m => m (M.Map Text Text)
getSymbolToCoinGeckoId = do
    let uri = "https://api.coingecko.com/api/v3/coins/list?include_platform=false"
        request = parseRequest_ uri
    bodyText <- liftIO $ catchAny (getResponseBody <$> httpLBS request) $ \e -> do
                           liftIO $ logM "System.Taffybar.Information.Crypto" WARNING $
                                  printf "Error fetching coins list from coin gecko %s" $ show e
                           return ""
    let coinInfos :: [CoinGeckoInfo]
        coinInfos = fromMaybe [] $ decode bodyText

    return $ M.fromList $ map (\CoinGeckoInfo { identifier = theId, symbol = theSymbol } ->
                        (theSymbol, theId)) coinInfos

newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map Text Text)

newtype CryptoPriceInfo = CryptoPriceInfo { lastPrice :: Double }

newtype CryptoPriceChannel (a :: Symbol) =
  CryptoPriceChannel (TChan CryptoPriceInfo, MVar CryptoPriceInfo)

getCryptoPriceChannel :: KnownSymbol a => TaffyIO (CryptoPriceChannel a)
getCryptoPriceChannel = do
  -- XXX: This is a gross hack that is needed to avoid deadlock
  symbolToId <- getStateDefault $ SymbolToCoinGeckoId <$> getSymbolToCoinGeckoId
  getStateDefault $ buildCryptoPriceChannel (60.0 :: Double) symbolToId

data CoinGeckoInfo =
  CoinGeckoInfo { identifier :: Text, symbol :: Text }
  deriving (Show)

instance FromJSON CoinGeckoInfo where
  parseJSON = withObject "CoinGeckoInfo" (\v -> CoinGeckoInfo <$> v .: "id" <*> v .: "symbol")

logCrypto :: MonadIO m => Priority -> String -> m ()
logCrypto p = liftIO . logM "System.Taffybar.Information.Crypto" p

resolveSymbolPair :: KnownSymbol a => Proxy a -> SymbolToCoinGeckoId -> Either String (Text, Text)
resolveSymbolPair sym symbolToId = do
  (symbolName, inCurrency) <- parseSymbolPair (symbolVal sym)
  cgIdentifier <- lookupSymbolCoinGeckoId symbolToId symbolName
  pure (cgIdentifier, inCurrency)

  where
    parseSymbolPair :: String -> Either String (Text, Text)
    parseSymbolPair symbolPair = case T.splitOn "-" (T.toLower $ T.pack symbolPair) of
      [symbolName, inCurrency] | not (T.null inCurrency) -> Right (symbolName, inCurrency)
      _ -> Left $ printf "Type parameter \"%s\" does not match the form \"ASSET-CURRENCY\"" symbolPair

    lookupSymbolCoinGeckoId :: SymbolToCoinGeckoId -> Text -> Either String Text
    lookupSymbolCoinGeckoId (SymbolToCoinGeckoId m) symbolName = maybeToEither
      (printf "Symbol \"%s\" not found in coin gecko list" (T.unpack symbolName))
      (M.lookup symbolName m)

buildCryptoPriceChannel ::
  forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)
buildCryptoPriceChannel delay symbolToId = do
  let initialBackoff = delay
  chan <- liftIO newBroadcastTChanIO
  var <- liftIO $ newMVar $ CryptoPriceInfo 0.0
  backoffVar <- liftIO $ newMVar initialBackoff

  let doWrites info = do
        _ <- swapMVar var info
        _ <- atomically $ writeTChan chan info
        _ <- swapMVar backoffVar initialBackoff
        return ()

  case resolveSymbolPair (Proxy :: Proxy a) symbolToId of
    Left err -> logCrypto WARNING err
    Right (cgIdentifier, inCurrency) ->
      void $ foreverWithVariableDelay $
           catchAny (liftIO $ getLatestPrice cgIdentifier inCurrency >>=
                            maybe (return ()) (doWrites . CryptoPriceInfo) >> return delay) $ \e -> do
                                     logCrypto WARNING $ printf "Error when fetching crypto price: %s" (show e)
                                     modifyMVar backoffVar $ \current ->
                                       return (min (current * 2) delay, current)

  return $ CryptoPriceChannel (chan, var)

getLatestPrice :: MonadIO m => Text -> Text -> m (Maybe Double)
getLatestPrice tokenId inCurrency = do
  let uri = printf "https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s"
            tokenId inCurrency
      request = parseRequest_ uri
  bodyText <- getResponseBody <$> httpLBS request
  return $ decode bodyText >>= parseMaybe ((.: Key.fromText tokenId) >=> (.: Key.fromText inCurrency))

getCryptoMeta :: MonadIO m => String -> String -> m LBS.ByteString
getCryptoMeta cmcAPIKey symbolName = do
  let headers = [("X-CMC_PRO_API_KEY", BS.fromString cmcAPIKey)] :: RequestHeaders
      uri = printf "https://pro-api.coinmarketcap.com/v1/cryptocurrency/info?symbol=%s"
            symbolName
      request = setRequestHeaders headers $ parseRequest_ uri
  getResponseBody <$> httpLBS request