summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Plugins/Kraken.hs
blob: 5d565e0123e6a1cb8c576eb28fc458c745148910 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}

module Xmobar.Plugins.Kraken (Kraken(..)) where

import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.Async (async, cancel)
import Control.Exception (bracket, catch)
import Control.Monad (forever, mzero, void, when)
import Data.Aeson
import Data.Aeson.Types (Parser, typeMismatch)
import Data.List (sort)
import Data.Text (Text, pack, unpack)
import GHC.Generics
import Network.WebSockets (ClientApp, ConnectionException(ConnectionClosed), receiveData, sendTextData)
import System.IO (hPutStrLn, stderr)
import Text.Read (readMaybe)
import Wuss (runSecureClient)
import Xmobar.Run.Exec(Exec(..))

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
    bracket (async $ reconnectOnConnectionClose $ wsClientApp ps mvar) cancel $ \_ -> do
      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 $ map (, 0.0) ps)

    where
      display :: Map.Map String Double -> String
      display m = unwords $ sort $ map (\x -> fst x ++ ": " ++ show (snd x)) $ Map.toList m

      reconnectOnConnectionClose :: ClientApp () -> IO ()
      reconnectOnConnectionClose ws = runSecureClient "ws.kraken.com" 443 "/" ws
        `catch` (\e -> when (e == ConnectionClosed) $ reconnectOnConnectionClose ws)

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