summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Plugins/Kraken.hs
blob: afe04db0a10a0aee43544b3b1dfcd9b0eb9db81d (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
{-# 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