atrade-brick/src/Main.hs

{-# LANGUAGE TemplateHaskell #-}
module Main where

import           Brick.AttrMap
import           Brick.BChan
import           Brick.Main
import           Brick.Types
import           Brick.Widgets.Border
import           Brick.Widgets.Core
import           Control.Concurrent
import qualified Control.Concurrent.BoundedChan as BC
import           Control.Exception
import           Control.Monad
import           Data.Aeson
import qualified Data.ByteString.Lazy           as B
import           Data.IORef
import qualified Data.List                      as L
import qualified Data.Map.Strict                as M
import qualified Graphics.Vty                   as Vty
import           Lens.Micro.Platform
import           Lens.Micro.TH
import           System.ZMQ4

import           ATrade.QuoteSource.Client
import           ATrade.Types

import           Config
import           QuoteTable

data Name = Viewport1
  deriving (Show, Eq, Ord)

data AppEvent = QuoteTableUpdate QuoteTable

data AppState = AppState {
  _quotes :: QuoteTable
}

makeLenses ''AppState

qsThread :: IORef QuoteTable -> AppConfig -> IO ()
qsThread quotetable config = withContext $ \ctx -> do
  qschan <- BC.newBoundedChan 1000
  bracket (startQuoteSourceClient qschan (config ^. tickers) ctx (config ^. quoteSourceEndpoint) defaultClientSecurityParams) stopQuoteSourceClient $ \_ -> forever $ do
    qsdata <- BC.readChan qschan
    case qsdata of
      QDTick tick -> handleNewTick quotetable tick
      _           -> return ()
  where
    handleNewTick s t = atomicModifyIORef s $ \table -> (updateTable table t, ())

quoteTableWriterThread :: IORef QuoteTable -> BChan AppEvent -> IO ()
quoteTableWriterThread qtRef chan = forever $ do
  threadDelay 1000000
  qt <- readIORef qtRef
  writeBChan chan $ QuoteTableUpdate qt


main :: IO ()
main = do
  maybeConfig <- decode' <$> B.readFile "atrade-brick.config"
  case maybeConfig of
    Nothing -> error "Can't parse config"
    Just config -> do
      let app = App {
                appDraw = draw,
                appChooseCursor = chooseCursor,
                appHandleEvent = handleEvent,
                appStartEvent = startEvent,
                appAttrMap = attrMap'
                    }
      quoteTableRef <- newIORef M.empty
      eventChan <- Brick.BChan.newBChan 10
      let buildVty = Vty.mkVty Vty.defaultConfig
      initialVty <- buildVty
      qsThreadId <- forkIO $ qsThread quoteTableRef config
      qtwThreadId <- forkIO $ quoteTableWriterThread quoteTableRef eventChan
      void $ customMain buildVty (Just eventChan) app (initialState M.empty)
  where
    initialState ref = AppState ref
    draw :: AppState -> [Widget Name]
    draw s = [hBox . L.intersperse vBorder $ hLimit 30 . padLeftRight 3 <$> [vBox ([str "Ticker", hBorder] ++ (txt <$> tickers s)),
                    vBox ([str "Last", hBorder] ++ (str <$> fmap (printEntry s qteLastPrice) (tickers s))),
                    vBox ([str "Bid", hBorder] ++ (str <$> fmap (printEntry s qteBid) (tickers s))),
                    vBox ([str "Ask", hBorder] ++ (str <$> fmap (printEntry s qteAsk) (tickers s)))] ]
    printEntry s l tickerId = case s ^. quotes . at tickerId of
      Just qte -> show $ qte ^. l
      Nothing  -> "-"
    tickers s = M.keys (s ^. quotes)
    chooseCursor s loc = Nothing
    handleEvent s event = case event of
      VtyEvent e -> case e of
        Vty.EvKey (Vty.KChar 'q') [] -> halt s
        _                            -> continue s
      AppEvent e -> case e of
        QuoteTableUpdate t -> continue $ AppState t
      _ -> continue s
    startEvent = return
    attrMap' s = attrMap Vty.defAttr []