    {-# 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