{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.Crypto
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides widgets for tracking the price of crypto currency
-- assets.
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Crypto where

import           Control.Concurrent
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Reader
import           Data.Aeson
import           Data.Aeson.Types
import qualified Data.Aeson.Key as Key
import qualified Data.ByteString.Lazy as LBS
import           Data.Maybe
import           Data.Proxy
import qualified Data.Text
import           GHC.TypeLits
import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import           Network.HTTP.Simple hiding (Proxy)
import           System.FilePath.Posix
import           System.Taffybar.Context
import           System.Taffybar.Information.Crypto hiding (symbol)
import           System.Taffybar.Util
import           System.Taffybar.Widget.Generic.AutoSizeImage
import           System.Taffybar.Widget.Generic.ChannelWidget
import           System.Taffybar.WindowIcon
import           Text.Printf

-- | Extends 'cryptoPriceLabel' with an icon corresponding to the symbol of the
-- purchase crypto that will appear to the left of the price label. See the
-- docstring for 'getCryptoPixbuf' for details about how this icon is retrieved.
-- Note that automatic icon retrieval requires a coinmarketcap api key to be set
-- at taffybar startup. As with 'cryptoPriceLabel', this function must be
-- invoked with a type application with the type string that expresses the
-- symbol of the relevant token and the underlying currency in which its price
-- should be expressed. See the docstring of 'cryptoPriceLabel' for details
-- about the exact format that this string should take.
cryptoPriceLabelWithIcon :: forall a. KnownSymbol a => TaffyIO Gtk.Widget
cryptoPriceLabelWithIcon :: forall (a :: Symbol). KnownSymbol a => TaffyIO Widget
cryptoPriceLabelWithIcon = do
  label <- forall (a :: Symbol). KnownSymbol a => TaffyIO Widget
cryptoPriceLabel @a
  let symbolPair = Proxy a -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
      symbol = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') FilePath
symbolPair
  hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0

  ctx <- ask
  let refresh =
        IO Pixbuf -> Int32 -> IO Pixbuf
forall a b. a -> b -> a
const (IO Pixbuf -> Int32 -> IO Pixbuf)
-> IO Pixbuf -> Int32 -> IO Pixbuf
forall a b. (a -> b) -> a -> b
$ (ReaderT Context IO Pixbuf -> Context -> IO Pixbuf)
-> Context -> ReaderT Context IO Pixbuf -> IO Pixbuf
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO Pixbuf -> Context -> IO Pixbuf
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (ReaderT Context IO Pixbuf -> IO Pixbuf)
-> ReaderT Context IO Pixbuf -> IO Pixbuf
forall a b. (a -> b) -> a -> b
$
        Pixbuf -> Maybe Pixbuf -> Pixbuf
forall a. a -> Maybe a -> a
fromMaybe (Pixbuf -> Maybe Pixbuf -> Pixbuf)
-> ReaderT Context IO Pixbuf
-> ReaderT Context IO (Maybe Pixbuf -> Pixbuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> Word32 -> ReaderT Context IO Pixbuf
forall (m :: * -> *). MonadIO m => Int32 -> Word32 -> m Pixbuf
pixBufFromColor Int32
10 Word32
0 ReaderT Context IO (Maybe Pixbuf -> Pixbuf)
-> ReaderT Context IO (Maybe Pixbuf) -> ReaderT Context IO Pixbuf
forall a b.
ReaderT Context IO (a -> b)
-> ReaderT Context IO a -> ReaderT Context IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> ReaderT Context IO (Maybe Pixbuf)
getCryptoPixbuf FilePath
symbol
  image <- autoSizeImageNew refresh Gtk.OrientationHorizontal

  Gtk.containerAdd hbox image
  Gtk.containerAdd hbox label

  Gtk.widgetShowAll hbox

  Gtk.toWidget hbox

newtype CMCAPIKey = CMCAPIKey String

-- | Set the coinmarketcap.com api key that will be used for retrieving crypto
-- icons that are not cached. This should occur before any attempts to retrieve
-- crypto icons happen. The easiest way to call this appropriately is to set it
-- as a 'startupHook'.
setCMCAPIKey :: String -> TaffyIO CMCAPIKey
setCMCAPIKey :: FilePath -> TaffyIO CMCAPIKey
setCMCAPIKey FilePath
key =
  TaffyIO CMCAPIKey -> TaffyIO CMCAPIKey
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (TaffyIO CMCAPIKey -> TaffyIO CMCAPIKey)
-> TaffyIO CMCAPIKey -> TaffyIO CMCAPIKey
forall a b. (a -> b) -> a -> b
$ CMCAPIKey -> TaffyIO CMCAPIKey
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CMCAPIKey -> TaffyIO CMCAPIKey) -> CMCAPIKey -> TaffyIO CMCAPIKey
forall a b. (a -> b) -> a -> b
$ FilePath -> CMCAPIKey
CMCAPIKey FilePath
key

-- | Build a label that will reflect the price of some token in some currency in
-- the coingecko API. This function accepts these valuesas a type parameter with
-- kind 'String' of the form `(symbol for asset being purchased)-(currency the
-- price should be expressed in)`. For example, the product string for the price
-- of bitcoin quoted in U.S. dollars is "BTC-USD". You can invoke this function
-- by enabling the TypeApplications language extension and passing the string
-- associated with the asset that you want to track as follows:
--
-- > cryptoPriceLabel @"BTC-USD"
cryptoPriceLabel :: forall a. KnownSymbol a => TaffyIO Gtk.Widget
cryptoPriceLabel :: forall (a :: Symbol). KnownSymbol a => TaffyIO Widget
cryptoPriceLabel = forall (a :: Symbol).
KnownSymbol a =>
TaffyIO (CryptoPriceChannel a)
getCryptoPriceChannel @a TaffyIO (CryptoPriceChannel a)
-> (CryptoPriceChannel a -> TaffyIO Widget) -> TaffyIO Widget
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CryptoPriceChannel a -> TaffyIO Widget
forall (a :: Symbol). CryptoPriceChannel a -> TaffyIO Widget
cryptoPriceLabel'

cryptoPriceLabel' :: CryptoPriceChannel a -> TaffyIO Gtk.Widget
cryptoPriceLabel' :: forall (a :: Symbol). CryptoPriceChannel a -> TaffyIO Widget
cryptoPriceLabel' (CryptoPriceChannel (TChan CryptoPriceInfo
chan, MVar CryptoPriceInfo
var)) = do
  label <- Maybe Text -> ReaderT Context IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
Gtk.labelNew Maybe Text
forall a. Maybe a
Nothing
  let updateWidget CryptoPriceInfo { lastPrice :: CryptoPriceInfo -> Double
lastPrice = Double
cryptoPrice } =
        IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
Gtk.labelSetMarkup Label
label (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                     FilePath -> Text
Data.Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Double -> FilePath
forall a. Show a => a -> FilePath
show Double
cryptoPrice
  void $ Gtk.onWidgetRealize label $
       readMVar var >>= updateWidget
  Gtk.toWidget =<< channelWidgetNew label chan updateWidget

cryptoIconsDir :: IO FilePath
cryptoIconsDir :: IO FilePath
cryptoIconsDir = (FilePath -> FilePath -> FilePath
</> FilePath
"crypto_icons") (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
taffyStateDir

pathForCryptoSymbol :: String -> IO FilePath
pathForCryptoSymbol :: FilePath -> IO FilePath
pathForCryptoSymbol FilePath
symbol =
  (FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s.png" FilePath
symbol) (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
cryptoIconsDir

-- | Retrieve a pixbuf image corresponding to the provided crypto symbol. The
-- image used will be retrieved from the file with the name `(pricesymbol).png`
-- from the directory defined by 'cryptoIconsDir'. If a file is not found there
-- and an an api key for coinmarketcap.com has been set using 'setCMCAPIKey', an
-- icon will be automatically be retrieved from coinmarketcap.com.
getCryptoPixbuf :: String -> TaffyIO (Maybe Gdk.Pixbuf)
getCryptoPixbuf :: FilePath -> ReaderT Context IO (Maybe Pixbuf)
getCryptoPixbuf = FilePath -> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe Pixbuf)
getCryptoIconFromCache (FilePath -> ReaderT Context IO (Maybe Pixbuf))
-> (FilePath -> ReaderT Context IO (Maybe Pixbuf))
-> FilePath
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) t a.
Monad m =>
(t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a)
<||> FilePath -> ReaderT Context IO (Maybe Pixbuf)
getCryptoIconFromCMC

getCryptoIconFromCache :: MonadIO m => String -> m (Maybe Gdk.Pixbuf)
getCryptoIconFromCache :: forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe Pixbuf)
getCryptoIconFromCache FilePath
symbol = IO (Maybe Pixbuf) -> m (Maybe Pixbuf)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Pixbuf) -> m (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> m (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$
  FilePath -> IO FilePath
pathForCryptoSymbol FilePath
symbol IO FilePath -> (FilePath -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO (Maybe Pixbuf)
safePixbufNewFromFile

getCryptoIconFromCMC :: String -> TaffyIO (Maybe Gdk.Pixbuf)
getCryptoIconFromCMC :: FilePath -> ReaderT Context IO (Maybe Pixbuf)
getCryptoIconFromCMC FilePath
symbol =
  MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT Context IO) Pixbuf
 -> ReaderT Context IO (Maybe Pixbuf))
-> MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ do
    CMCAPIKey cmcAPIKey <- ReaderT Context IO (Maybe CMCAPIKey)
-> MaybeT (ReaderT Context IO) CMCAPIKey
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ReaderT Context IO (Maybe CMCAPIKey)
forall t. Typeable t => Taffy IO (Maybe t)
getState
    MaybeT $ lift $ getCryptoIconFromCMC' cmcAPIKey symbol

getCryptoIconFromCMC' :: String -> String -> IO (Maybe Gdk.Pixbuf)
getCryptoIconFromCMC' :: FilePath -> FilePath -> IO (Maybe Pixbuf)
getCryptoIconFromCMC' FilePath
cmcAPIKey FilePath
symbol = do
  jsonText <- FilePath -> FilePath -> IO ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> FilePath -> m ByteString
getCryptoMeta FilePath
cmcAPIKey FilePath
symbol
  let uri = FilePath -> ByteString -> Maybe Text
getIconURIFromJSON FilePath
symbol ByteString
jsonText Maybe Text -> (Text -> Maybe Request) -> Maybe Request
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Maybe Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest (FilePath -> Maybe Request)
-> (Text -> FilePath) -> Text -> Maybe Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Data.Text.unpack
  path <- pathForCryptoSymbol symbol
  maybe (return ()) (`downloadURIToPath` path) uri
  safePixbufNewFromFile path

getIconURIFromJSON :: String -> LBS.ByteString -> Maybe Data.Text.Text
getIconURIFromJSON :: FilePath -> ByteString -> Maybe Text
getIconURIFromJSON FilePath
symbol ByteString
jsonText =
  ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
jsonText Maybe Object -> (Object -> Maybe Text) -> Maybe Text
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 Text) -> Object -> Maybe Text
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe
           ((Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data") (Object -> Parser Object)
-> (Object -> Parser Text) -> Object -> Parser Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: FilePath -> Key
Key.fromString FilePath
symbol) (Object -> Parser Object)
-> (Object -> Parser Text) -> Object -> Parser Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"logo"))