{-# 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 :: forall (m :: * -> *). MonadIO m => m (Map Text Text)
getSymbolToCoinGeckoId = do
    let uri :: String
uri = String
"https://api.coingecko.com/api/v3/coins/list?include_platform=false"
        request :: Request
request = String -> Request
parseRequest_ String
uri
    bodyText <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> (SomeException -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
catchAny (Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS Request
request) ((SomeException -> IO ByteString) -> IO ByteString)
-> (SomeException -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
                           IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Information.Crypto" Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                                  String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Error fetching coins list from coin gecko %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
                           ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
    let coinInfos :: [CoinGeckoInfo]
        coinInfos = [CoinGeckoInfo] -> Maybe [CoinGeckoInfo] -> [CoinGeckoInfo]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CoinGeckoInfo] -> [CoinGeckoInfo])
-> Maybe [CoinGeckoInfo] -> [CoinGeckoInfo]
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe [CoinGeckoInfo]
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bodyText

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

newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map Text Text)

newtype CryptoPriceInfo = CryptoPriceInfo { CryptoPriceInfo -> Double
lastPrice :: Double }

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

getCryptoPriceChannel :: KnownSymbol a => TaffyIO (CryptoPriceChannel a)
getCryptoPriceChannel :: forall (a :: Symbol).
KnownSymbol a =>
TaffyIO (CryptoPriceChannel a)
getCryptoPriceChannel = do
  -- XXX: This is a gross hack that is needed to avoid deadlock
  symbolToId <- Taffy IO SymbolToCoinGeckoId -> Taffy IO SymbolToCoinGeckoId
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (Taffy IO SymbolToCoinGeckoId -> Taffy IO SymbolToCoinGeckoId)
-> Taffy IO SymbolToCoinGeckoId -> Taffy IO SymbolToCoinGeckoId
forall a b. (a -> b) -> a -> b
$ Map Text Text -> SymbolToCoinGeckoId
SymbolToCoinGeckoId (Map Text Text -> SymbolToCoinGeckoId)
-> ReaderT Context IO (Map Text Text)
-> Taffy IO SymbolToCoinGeckoId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context IO (Map Text Text)
forall (m :: * -> *). MonadIO m => m (Map Text Text)
getSymbolToCoinGeckoId
  getStateDefault $ buildCryptoPriceChannel (60.0 :: Double) symbolToId

data CoinGeckoInfo =
  CoinGeckoInfo { CoinGeckoInfo -> Text
identifier :: Text, CoinGeckoInfo -> Text
symbol :: Text }
  deriving (Int -> CoinGeckoInfo -> String -> String
[CoinGeckoInfo] -> String -> String
CoinGeckoInfo -> String
(Int -> CoinGeckoInfo -> String -> String)
-> (CoinGeckoInfo -> String)
-> ([CoinGeckoInfo] -> String -> String)
-> Show CoinGeckoInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CoinGeckoInfo -> String -> String
showsPrec :: Int -> CoinGeckoInfo -> String -> String
$cshow :: CoinGeckoInfo -> String
show :: CoinGeckoInfo -> String
$cshowList :: [CoinGeckoInfo] -> String -> String
showList :: [CoinGeckoInfo] -> String -> String
Show)

instance FromJSON CoinGeckoInfo where
  parseJSON :: Value -> Parser CoinGeckoInfo
parseJSON = String
-> (Object -> Parser CoinGeckoInfo)
-> Value
-> Parser CoinGeckoInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"CoinGeckoInfo" (\Object
v -> Text -> Text -> CoinGeckoInfo
CoinGeckoInfo (Text -> Text -> CoinGeckoInfo)
-> Parser Text -> Parser (Text -> CoinGeckoInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" Parser (Text -> CoinGeckoInfo)
-> Parser Text -> Parser CoinGeckoInfo
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"symbol")

logCrypto :: MonadIO m => Priority -> String -> m ()
logCrypto :: forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logCrypto Priority
p = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Information.Crypto" Priority
p

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

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

    lookupSymbolCoinGeckoId :: SymbolToCoinGeckoId -> Text -> Either String Text
    lookupSymbolCoinGeckoId :: SymbolToCoinGeckoId -> Text -> Either String Text
lookupSymbolCoinGeckoId (SymbolToCoinGeckoId Map Text Text
m) Text
symbolName = String -> Maybe Text -> Either String Text
forall b a. b -> Maybe a -> Either b a
maybeToEither
      (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Symbol \"%s\" not found in coin gecko list" (Text -> String
T.unpack Text
symbolName))
      (Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
symbolName Map Text Text
m)

buildCryptoPriceChannel ::
  forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)
buildCryptoPriceChannel :: forall (a :: Symbol).
KnownSymbol a =>
Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)
buildCryptoPriceChannel Double
delay SymbolToCoinGeckoId
symbolToId = do
  let initialBackoff :: Double
initialBackoff = Double
delay
  chan <- IO (TChan CryptoPriceInfo)
-> ReaderT Context IO (TChan CryptoPriceInfo)
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TChan CryptoPriceInfo)
forall a. IO (TChan a)
newBroadcastTChanIO
  var <- liftIO $ newMVar $ CryptoPriceInfo 0.0
  backoffVar <- liftIO $ newMVar initialBackoff

  let doWrites CryptoPriceInfo
info = do
        _ <- MVar CryptoPriceInfo -> CryptoPriceInfo -> IO CryptoPriceInfo
forall a. MVar a -> a -> IO a
swapMVar MVar CryptoPriceInfo
var CryptoPriceInfo
info
        _ <- atomically $ writeTChan chan info
        _ <- swapMVar backoffVar initialBackoff
        return ()

  case resolveSymbolPair (Proxy :: Proxy a) symbolToId of
    Left String
err -> Priority -> String -> ReaderT Context IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logCrypto Priority
WARNING String
err
    Right (Text
cgIdentifier, Text
inCurrency) ->
      ReaderT Context IO ThreadId -> ReaderT Context IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Context IO ThreadId -> ReaderT Context IO ())
-> ReaderT Context IO ThreadId -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ IO Double -> ReaderT Context IO ThreadId
forall (m :: * -> *) d.
(MonadIO m, RealFrac d) =>
IO d -> m ThreadId
foreverWithVariableDelay (IO Double -> ReaderT Context IO ThreadId)
-> IO Double -> ReaderT Context IO ThreadId
forall a b. (a -> b) -> a -> b
$
           IO Double -> (SomeException -> IO Double) -> IO Double
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
catchAny (IO Double -> IO Double
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> IO Double) -> IO Double -> IO Double
forall a b. (a -> b) -> a -> b
$ Text -> Text -> IO (Maybe Double)
forall (m :: * -> *). MonadIO m => Text -> Text -> m (Maybe Double)
getLatestPrice Text
cgIdentifier Text
inCurrency IO (Maybe Double) -> (Maybe Double -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                            IO () -> (Double -> IO ()) -> Maybe Double -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (CryptoPriceInfo -> IO ()
doWrites (CryptoPriceInfo -> IO ())
-> (Double -> CryptoPriceInfo) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> CryptoPriceInfo
CryptoPriceInfo) IO () -> IO Double -> IO Double
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
delay) ((SomeException -> IO Double) -> IO Double)
-> (SomeException -> IO Double) -> IO Double
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
                                     Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logCrypto Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Error when fetching crypto price: %s" (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
                                     MVar Double -> (Double -> IO (Double, Double)) -> IO Double
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Double
backoffVar ((Double -> IO (Double, Double)) -> IO Double)
-> (Double -> IO (Double, Double)) -> IO Double
forall a b. (a -> b) -> a -> b
$ \Double
current ->
                                       (Double, Double) -> IO (Double, Double)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double
current Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2) Double
delay, Double
current)

  return $ CryptoPriceChannel (chan, var)

getLatestPrice :: MonadIO m => Text -> Text -> m (Maybe Double)
getLatestPrice :: forall (m :: * -> *). MonadIO m => Text -> Text -> m (Maybe Double)
getLatestPrice Text
tokenId Text
inCurrency = do
  let uri :: String
uri = String -> Text -> Text -> String
forall r. PrintfType r => String -> r
printf String
"https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s"
            Text
tokenId Text
inCurrency
      request :: Request
request = String -> Request
parseRequest_ String
uri
  bodyText <- Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody (Response ByteString -> ByteString)
-> m (Response ByteString) -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS Request
request
  return $ decode bodyText >>= parseMaybe ((.: Key.fromText tokenId) >=> (.: Key.fromText inCurrency))

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