From 7d4e3efca1cb1164040a4a64c1747a9aa163a9f0 Mon Sep 17 00:00:00 2001 From: Amir Saeid Date: Tue, 29 Jun 2021 22:35:58 +0100 Subject: Add Kraken plugin --- src/Xmobar/Plugins/Kraken.hs | 154 +++++++++++++++++++++++++++++++++++++++++++ src/Xmobar/Run/Types.hs | 7 ++ xmobar.cabal | 14 ++++ 3 files changed, 175 insertions(+) create mode 100644 src/Xmobar/Plugins/Kraken.hs diff --git a/src/Xmobar/Plugins/Kraken.hs b/src/Xmobar/Plugins/Kraken.hs new file mode 100644 index 0000000..68b3394 --- /dev/null +++ b/src/Xmobar/Plugins/Kraken.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module Xmobar.Plugins.Kraken (Kraken(..)) where + +import Control.Concurrent +import Control.Monad (forever, mzero, void) +import Data.Aeson +import Data.Aeson.Types (Parser, typeMismatch) +import Data.List (sort) +import Data.Text (Text, pack, unpack) +import GHC.Generics +import System.IO (hPutStrLn, stderr) +import Text.Read (readMaybe) +import Xmobar.Run.Exec(Exec(..)) +import Network.WebSockets (ClientApp, receiveData, sendTextData) +import Wuss (runSecureClient) + +import qualified Data.HashMap.Lazy as HML (lookup) +import qualified Data.Map as Map +import qualified Data.Vector as V + +data Kraken = Kraken [String] String + deriving (Read,Show) + +instance Exec Kraken where + alias (Kraken _ a) = a + start (Kraken ps _) cb = do + mvar <- newEmptyMVar + forkIO $ runSecureClient "ws.kraken.com" 443 "/" $ wsClientApp ps mvar + let loop mv p = do + v <- takeMVar mv + let g = Map.insert (unpack $ fst v) (snd v) p + cb (display g) + loop mv g + + loop mvar (Map.fromList $ zip ps (repeat 0.0)) + + where + display :: Map.Map String Double -> String + display m = unwords $ sort $ map (\x -> fst x ++ ": " ++ show (snd x)) $ Map.toList m + +wsClientApp :: [String] -> MVar (Text, Double) -> ClientApp () +wsClientApp ps mvar connection = do + sendTextData connection (encode (Subscribe { event = "subscribe", pair = map pack ps, subscription = Subscription { name = "ticker" }} )) + void . forever $ do + message <- receiveData connection + case (eitherDecode message :: Either String Message) of + Right m -> + case m of + TickerMessage _ ti _ tp -> putMVar mvar (tp, askPrice $ ask ti) + _ -> return () + Left e -> hPutStrLn stderr e + +data Ask = Ask { + askPrice :: Double + , askWholeLotVolume :: Int + , askLotVolume :: Double + } deriving Show + +parseDoubleString :: Value -> Parser Double +parseDoubleString v = do + j <- parseJSON v + case readMaybe j of + Just num -> return num + Nothing -> typeMismatch "Double inside a String" v + +instance FromJSON Ask where + parseJSON (Array v) + | V.length v == 3 = do + p <- parseDoubleString $ v V.! 0 + w <- parseJSON $ v V.! 1 + l <- parseDoubleString $ v V.! 2 + return $ Ask { askPrice = p, askWholeLotVolume = w, askLotVolume = l } + | otherwise = mzero + parseJSON nonArray = typeMismatch "Array" nonArray + +data Bid = Bid { + bidPrice :: Double + , bidWholeLotVolume :: Int + , bidLotVolume :: Double + } deriving Show + +instance FromJSON Bid where + parseJSON (Array v) + | V.length v == 3 = do + p <- parseDoubleString $ v V.! 0 + w <- parseJSON $ v V.! 1 + l <- parseDoubleString $ v V.! 2 + return $ Bid { bidPrice = p, bidWholeLotVolume = w, bidLotVolume = l } + | otherwise = mzero + parseJSON nonArray = typeMismatch "Array" nonArray + +data Close = Close { + closePrice :: Double + , closeLotVolume :: Double + } deriving Show + +instance FromJSON Close where + parseJSON (Array v) + | V.length v == 2 = do + p <- parseDoubleString $ v V.! 0 + l <- parseDoubleString $ v V.! 1 + return $ Close { closePrice= p, closeLotVolume = l } + | otherwise = mzero + parseJSON nonArray = typeMismatch "Array" nonArray + +data TickerInformation = TickerInformation { + ask :: Ask + , bid :: Bid + , close :: Close + } deriving Show + +instance FromJSON TickerInformation where + parseJSON = withObject "P" $ \v -> TickerInformation + <$> v .: "a" + <*> v .: "b" + <*> v .: "c" + +data Message = + Heartbeat + | TickerMessage { channelId :: Int, tickerInformation :: TickerInformation, channelName :: Text, tickerPair :: Text } + | SubscriptionStatus { channelName :: Text, status :: Text, subscriptionPair :: Text } + | SystemStatus { connectionId :: Integer, status :: Text, version :: Text } + | UnrecognizedMessage String + deriving Show + +newtype Subscription = Subscription { name :: Text } deriving (Generic, Show) +instance ToJSON Subscription where + toEncoding = genericToEncoding defaultOptions + +data Subscribe = Subscribe { event :: Text, pair :: [Text], subscription :: Subscription } deriving (Generic, Show) +instance ToJSON Subscribe where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON Message where + parseJSON (Object o) = case HML.lookup (pack "event") o of + Just (String "heartbeat") -> pure Heartbeat + Just (String "systemStatus") -> systemStatus o + Just (String "subscriptionStatus") -> subscriptionStatus o + Just eventType -> pure $ UnrecognizedMessage $ "Unrecognized event type " ++ show eventType + Nothing -> pure $ UnrecognizedMessage "Missing event" + where + systemStatus obj = SystemStatus <$> obj .: "connectionID" <*> obj .: "status" <*> obj .: "version" + subscriptionStatus obj = SubscriptionStatus <$> obj .: "channelName" <*> obj .: "status" <*> obj .: "pair" + parseJSON (Array a) + | V.length a == 4 = do + cId <- parseJSON $ a V.! 0 + info <- parseJSON $ a V.! 1 + cName <- parseJSON $ a V.! 2 + p <- parseJSON $ a V.! 3 + pure $ TickerMessage { channelId = cId, tickerInformation = info, channelName = cName, tickerPair = p } + | otherwise = mzero + parseJSON v = typeMismatch "Object or Array" v diff --git a/src/Xmobar/Run/Types.hs b/src/Xmobar/Run/Types.hs index deec8ba..0d4ed42 100644 --- a/src/Xmobar/Run/Types.hs +++ b/src/Xmobar/Run/Types.hs @@ -41,6 +41,10 @@ import Xmobar.Plugins.MBox import Xmobar.Plugins.DateZone #endif +#ifdef KRAKEN +import Xmobar.Plugins.Kraken +#endif + import Xmobar.Run.Command -- | An alias for tuple types that is more convenient for long lists. @@ -61,6 +65,9 @@ runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: #endif #ifdef DATEZONE DateZone :*: +#endif +#ifdef KRAKEN + Kraken :*: #endif MarqueePipeReader :*: () runnableTypes = undefined diff --git a/xmobar.cabal b/xmobar.cabal index 5b3275c..a4d79bd 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -92,6 +92,10 @@ flag with_weather description: Enable weather plugin. default: True +flag with_kraken + description: Enable Kraken plugin. + default: False + library default-language: Haskell2010 hs-source-dirs: src @@ -274,6 +278,16 @@ library build-depends: http-conduit, http-types cpp-options: -DUVMETER + if flag(with_kraken) + other-modules: Xmobar.Plugins.Kraken + build-depends: aeson == 1.5.6.* + , text == 1.2.4.* + , unordered-containers == 0.2.14.* + , vector == 0.12.3.* + , wuss == 1.1.* + , websockets == 0.12.* + cpp-options: -DKRAKEN + if os(freebsd) -- enables freebsd specific code build-depends: bsd-sysctl -- cgit v1.2.3