{-# 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           BroadcastChan
import           Control.Concurrent
import           Control.Exception.Enclosed (catchAny)
import           Control.Monad
import           Control.Monad.IO.Class
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 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 T.Text T.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
    ByteString
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]
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

    Map Text Text -> m (Map Text Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text Text -> m (Map Text Text))
-> Map Text Text -> m (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ (CoinGeckoInfo -> (Text, Text))
-> [CoinGeckoInfo] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\CoinGeckoInfo { identifier :: CoinGeckoInfo -> Text
identifier = Text
theId, symbol :: CoinGeckoInfo -> Text
symbol = Text
theSymbol } ->
                        (Text
theSymbol, Text
theId)) [CoinGeckoInfo]
coinInfos

newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map T.Text T.Text)

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

newtype CryptoPriceChannel (a :: Symbol) =
  CryptoPriceChannel (BroadcastChan In 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
  SymbolToCoinGeckoId
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
  TaffyIO (CryptoPriceChannel a) -> TaffyIO (CryptoPriceChannel a)
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (TaffyIO (CryptoPriceChannel a) -> TaffyIO (CryptoPriceChannel a))
-> TaffyIO (CryptoPriceChannel a) -> TaffyIO (CryptoPriceChannel a)
forall a b. (a -> b) -> a -> b
$ Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)
forall (a :: Symbol).
KnownSymbol a =>
Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a)
buildCryptoPriceChannel (Double
60.0 :: Double) SymbolToCoinGeckoId
symbolToId

data CoinGeckoInfo =
  CoinGeckoInfo { CoinGeckoInfo -> Text
identifier :: T.Text, CoinGeckoInfo -> Text
symbol :: T.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")

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 Map Text Text
symbolToId) = do
  let initialBackoff :: Double
initialBackoff = Double
delay
  BroadcastChan In CryptoPriceInfo
chan <- ReaderT Context IO (BroadcastChan In CryptoPriceInfo)
forall (m :: * -> *) a. MonadIO m => m (BroadcastChan In a)
newBroadcastChan
  MVar CryptoPriceInfo
var <- IO (MVar CryptoPriceInfo)
-> ReaderT Context IO (MVar CryptoPriceInfo)
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar CryptoPriceInfo)
 -> ReaderT Context IO (MVar CryptoPriceInfo))
-> IO (MVar CryptoPriceInfo)
-> ReaderT Context IO (MVar CryptoPriceInfo)
forall a b. (a -> b) -> a -> b
$ CryptoPriceInfo -> IO (MVar CryptoPriceInfo)
forall a. a -> IO (MVar a)
newMVar (CryptoPriceInfo -> IO (MVar CryptoPriceInfo))
-> CryptoPriceInfo -> IO (MVar CryptoPriceInfo)
forall a b. (a -> b) -> a -> b
$ Double -> CryptoPriceInfo
CryptoPriceInfo Double
0.0
  MVar Double
backoffVar <- IO (MVar Double) -> ReaderT Context IO (MVar Double)
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar Double) -> ReaderT Context IO (MVar Double))
-> IO (MVar Double) -> ReaderT Context IO (MVar Double)
forall a b. (a -> b) -> a -> b
$ Double -> IO (MVar Double)
forall a. a -> IO (MVar a)
newMVar Double
initialBackoff

  let doWrites :: CryptoPriceInfo -> IO ()
doWrites CryptoPriceInfo
info = do
        CryptoPriceInfo
_ <- MVar CryptoPriceInfo -> CryptoPriceInfo -> IO CryptoPriceInfo
forall a. MVar a -> a -> IO a
swapMVar MVar CryptoPriceInfo
var CryptoPriceInfo
info
        Bool
_ <- BroadcastChan In CryptoPriceInfo -> CryptoPriceInfo -> IO Bool
forall (m :: * -> *) a.
MonadIO m =>
BroadcastChan In a -> a -> m Bool
writeBChan BroadcastChan In CryptoPriceInfo
chan CryptoPriceInfo
info
        Double
_ <- MVar Double -> Double -> IO Double
forall a. MVar a -> a -> IO a
swapMVar MVar Double
backoffVar Double
initialBackoff
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  let symbolPair :: Text
symbolPair = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
      (Text
symbolName:Text
inCurrency:[Text]
_) = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"-" Text
symbolPair

  case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Text
T.toLower Text
symbolName) Map Text Text
symbolToId of
    Maybe Text
Nothing -> IO () -> ReaderT Context IO ()
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Context IO ()) -> IO () -> ReaderT Context 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 -> Text -> String
forall r. PrintfType r => String -> r
printf String
"Symbol %s not found in coin gecko list" Text
symbolName
    Just Text
cgIdentifier ->
      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 -> Text
T.toLower 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
                                     String -> Priority -> String -> SomeException -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
String -> Priority -> String -> t -> m ()
logPrintF String
"System.Taffybar.Information.Crypto"
                                               Priority
WARNING String
"Error when fetching crypto price: %s" 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)

  CryptoPriceChannel a -> TaffyIO (CryptoPriceChannel a)
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CryptoPriceChannel a -> TaffyIO (CryptoPriceChannel a))
-> CryptoPriceChannel a -> TaffyIO (CryptoPriceChannel a)
forall a b. (a -> b) -> a -> b
$ (BroadcastChan In CryptoPriceInfo, MVar CryptoPriceInfo)
-> CryptoPriceChannel a
forall (a :: Symbol).
(BroadcastChan In CryptoPriceInfo, MVar CryptoPriceInfo)
-> CryptoPriceChannel a
CryptoPriceChannel (BroadcastChan In CryptoPriceInfo
chan, MVar CryptoPriceInfo
var)

getLatestPrice :: MonadIO m => T.Text -> T.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
  ByteString
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
  Maybe Double -> m (Maybe Double)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Double -> m (Maybe Double))
-> Maybe Double -> m (Maybe Double)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bodyText Maybe Object -> (Object -> Maybe Double) -> Maybe Double
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Parser Double) -> Object -> Maybe Double
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe ((Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Text -> Key
Key.fromText Text
tokenId) (Object -> Parser Object)
-> (Object -> Parser Double) -> Object -> Parser Double
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Object -> Key -> Parser Double
forall a. FromJSON a => Object -> Key -> Parser a
.: Text -> Key
Key.fromText Text
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