summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar')
-rw-r--r--src/Xmobar/Plugins/Kraken.hs154
-rw-r--r--src/Xmobar/Run/Types.hs7
2 files changed, 161 insertions, 0 deletions
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.
@@ -62,5 +66,8 @@ runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*:
#ifdef DATEZONE
DateZone :*:
#endif
+#ifdef KRAKEN
+ Kraken :*:
+#endif
MarqueePipeReader :*: ()
runnableTypes = undefined