{-# 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.List.Split
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
  Widget
label <- forall (a :: Symbol). KnownSymbol a => TaffyIO Widget
cryptoPriceLabel @a
  let symbolPair :: FilePath
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 :: FilePath
symbol = [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
head ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"-" FilePath
symbolPair
  Box
hbox <- Orientation -> Int32 -> ReaderT Context IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0

  Context
ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let refresh :: Int32 -> IO Pixbuf
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
image <- (Int32 -> IO Pixbuf) -> Orientation -> ReaderT Context IO Image
forall (m :: * -> *).
MonadIO m =>
(Int32 -> IO Pixbuf) -> Orientation -> m Image
autoSizeImageNew Int32 -> IO Pixbuf
refresh Orientation
Gtk.OrientationHorizontal

  Box -> Image -> ReaderT Context IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
hbox Image
image
  Box -> Widget -> ReaderT Context IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
hbox Widget
label

  Box -> ReaderT Context IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll Box
hbox

  Box -> TaffyIO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Box
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 (BroadcastChan In CryptoPriceInfo
chan, MVar CryptoPriceInfo
var)) = do
  Label
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 -> IO ()
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
  ReaderT Context IO SignalHandlerId -> ReaderT Context IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Context IO SignalHandlerId -> ReaderT Context IO ())
-> ReaderT Context IO SignalHandlerId -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ Label
-> ((?self::Label) => IO ()) -> ReaderT Context IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
Gtk.onWidgetRealize Label
label (((?self::Label) => IO ()) -> ReaderT Context IO SignalHandlerId)
-> ((?self::Label) => IO ()) -> ReaderT Context IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
       MVar CryptoPriceInfo -> IO CryptoPriceInfo
forall a. MVar a -> IO a
readMVar MVar CryptoPriceInfo
var IO CryptoPriceInfo -> (CryptoPriceInfo -> 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
>>= CryptoPriceInfo -> IO ()
updateWidget
  Label -> TaffyIO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (Label -> TaffyIO Widget)
-> ReaderT Context IO Label -> TaffyIO Widget
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Label
-> BroadcastChan In CryptoPriceInfo
-> (CryptoPriceInfo -> IO ())
-> ReaderT Context IO Label
forall (m :: * -> *) w a.
(MonadIO m, IsWidget w) =>
w -> BroadcastChan In a -> (a -> IO ()) -> m w
channelWidgetNew Label
label BroadcastChan In CryptoPriceInfo
chan CryptoPriceInfo -> IO ()
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 FilePath
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
    ReaderT Context IO (Maybe Pixbuf)
-> MaybeT (ReaderT Context IO) Pixbuf
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ReaderT Context IO (Maybe Pixbuf)
 -> MaybeT (ReaderT Context IO) Pixbuf)
-> ReaderT Context IO (Maybe Pixbuf)
-> MaybeT (ReaderT Context IO) Pixbuf
forall a b. (a -> b) -> a -> b
$ IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO (Maybe Pixbuf)
getCryptoIconFromCMC' FilePath
cmcAPIKey FilePath
symbol

getCryptoIconFromCMC' :: String -> String -> IO (Maybe Gdk.Pixbuf)
getCryptoIconFromCMC' :: FilePath -> FilePath -> IO (Maybe Pixbuf)
getCryptoIconFromCMC' FilePath
cmcAPIKey FilePath
symbol = do
  ByteString
jsonText <- FilePath -> FilePath -> IO ByteString
forall (m :: * -> *).
MonadIO m =>
FilePath -> FilePath -> m ByteString
getCryptoMeta FilePath
cmcAPIKey FilePath
symbol
  let uri :: Maybe Request
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
  FilePath
path <- FilePath -> IO FilePath
pathForCryptoSymbol FilePath
symbol
  IO () -> (Request -> IO ()) -> Maybe Request -> 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 ()) (Request -> FilePath -> IO ()
`downloadURIToPath` FilePath
path) Maybe Request
uri
  FilePath -> IO (Maybe Pixbuf)
safePixbufNewFromFile FilePath
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"))