256 lines
10 KiB
Haskell
256 lines
10 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
module Run (run) where
|
|
|
|
import Import
|
|
import Chart
|
|
import Types
|
|
import Control.Concurrent
|
|
import Data.Aeson (encodeFile)
|
|
import Data.Bits
|
|
import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree)
|
|
import DearImGui
|
|
import DearImGui.Plot
|
|
import DearImGui.OpenGL3
|
|
import DearImGui.SDL
|
|
import Data.Time.Clock
|
|
import Graphics.GL
|
|
import SDL
|
|
--import Data.StateVar
|
|
import qualified Data.Text as T
|
|
import qualified Data.List as L
|
|
import qualified Data.HashMap.Strict as HM
|
|
--import qualified Data.FingerTree as FT
|
|
|
|
import IBClient.Connection
|
|
import Import (Chart(chartContractID))
|
|
|
|
run :: RIO App ()
|
|
run = do
|
|
-- set up IB connection & start threads feeding stuff
|
|
|
|
renderLoop
|
|
|
|
-- close connections to IB
|
|
|
|
shutdownApp :: RIO App ()
|
|
shutdownApp = do
|
|
win <- appWindow <$> ask
|
|
-- save settings & config
|
|
(V2 w h) <- liftIO $ get $ windowSize win
|
|
settings <- appSettings <$> ask
|
|
refs <- appRefs <$> ask
|
|
host' <- liftIO . readTVarIO . twsConnectionRefsHost . twsConnectionRefs $ refs
|
|
port' <- liftIO . readTVarIO . twsConnectionRefsPort . twsConnectionRefs $ refs
|
|
let settings' = settings & windowParams . windowWidth .~ fromIntegral w
|
|
& windowParams . windowHeight .~ fromIntegral h
|
|
& twsConnection . host .~ host'
|
|
& twsConnection . port .~ port'
|
|
liftIO $ encodeFile "settings.json" settings'
|
|
logInfo $ display ("Settings Saved" :: Text)
|
|
-- save cached data
|
|
liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache"
|
|
charts <- liftIO . readTVarIO . appCharts $ refs
|
|
forM_ (HM.toList charts) $ \(symbol,tc) -> do
|
|
c@Chart{..} <- liftIO . readTVarIO $ tc
|
|
today <- liftIO $ utctDay <$> getCurrentTime
|
|
liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID
|
|
let (_, chartData') = getUpdatedChartCache c (Just $ ChartSettings 5 Nothing Nothing)
|
|
newData = HM.toList
|
|
. fmap (filter (\ChartPoint{..} -> 0 /= volume))
|
|
. HM.alter (Just . maybe chartData' (<>chartData')) today
|
|
. fmap toList
|
|
$ chartHistData
|
|
forM_ newData $ \(day, dat) -> do
|
|
liftIO $ encodeFile ("cache/" <> show chartContractID <> "/" <> show day <> ".json") dat
|
|
logInfo $ display $ ppShow' settings'
|
|
|
|
renderLoop :: RIO App ()
|
|
renderLoop = do
|
|
win <- appWindow <$> ask
|
|
|
|
let checkEvents = do
|
|
pollEventWithImGui >>= \case
|
|
Nothing ->
|
|
return False
|
|
Just event ->
|
|
(isQuit event ||) <$> checkEvents
|
|
|
|
isQuit event =
|
|
SDL.eventPayload event == SDL.QuitEvent
|
|
|
|
close <- liftIO checkEvents
|
|
if close
|
|
then shutdownApp
|
|
else do
|
|
refs' <- appRefs <$> ask
|
|
data' <- appData <$> ask
|
|
selectedAccount <- readTVarIO $ currentAccount refs'
|
|
let sendQ = twsConnectionSend $ twsConnectionRefs refs'
|
|
-- Tell ImGui we're starting a new frame
|
|
liftIO $ do
|
|
openGL3NewFrame
|
|
sdl2NewFrame
|
|
newFrame
|
|
|
|
|
|
-- Menu bar
|
|
withMainMenuBarOpen $ do
|
|
withMenuOpen "File" $ do
|
|
menuItem "Quit" >>= \case
|
|
False -> return ()
|
|
True -> shutdownApp
|
|
let cr = twsConnectionRefs refs'
|
|
accs <- fmap HM.keys $ liftIO $ readTVarIO $ Types.accounts data'
|
|
withComboOpen "Account" (fromMaybe "Select account" selectedAccount) $ do
|
|
forM_ accs $ \a -> do
|
|
selectable a >>= \case
|
|
False -> return ()
|
|
True -> switchAccountTo a
|
|
let cStatus = twsConnectionStatus cr
|
|
connHost <- liftIO $ readTVarIO $ twsConnectionRefsHost cr
|
|
connPort <- liftIO $ readTVarIO $ twsConnectionRefsPort cr
|
|
connStatus <- liftIO $ readTVarIO cStatus
|
|
when (connStatus == TWSDisconnected) $ button "Connect" >>= \case
|
|
False -> return ()
|
|
True -> do
|
|
if connStatus == TWSDisconnected then do
|
|
logDebug $ display ("Connecting to TWS on " <> connHost <> ":" <> connPort <> "." :: Text)
|
|
app <- ask
|
|
void $ liftIO $ forkIO $ forkClient app
|
|
else do
|
|
logInfo $ display ("Tried to connect, but we are connected" :: Text)
|
|
return ()
|
|
cStatusText <- liftIO $ get (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus Text)
|
|
textColored (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus ImVec4) cStatusText
|
|
|
|
|
|
bracket_ (begin "TWS-Connection") end $ do
|
|
let cr = twsConnectionRefs refs'
|
|
let cStatus = twsConnectionStatus cr
|
|
let cHost = twsConnectionRefsHost cr
|
|
let cPort = twsConnectionRefsPort cr
|
|
void $ inputText "Host" cHost 255
|
|
void $ inputText "Port" cPort 255
|
|
button "Connect" >>= \case
|
|
False -> return ()
|
|
True -> do
|
|
connStatus <- liftIO $ readTVarIO cStatus
|
|
connHost <- liftIO $ readTVarIO cHost
|
|
connPort <- liftIO $ readTVarIO cPort
|
|
if connStatus == TWSDisconnected then do
|
|
logDebug $ display ("Connecting to TWS on " <> connHost <> ":" <> connPort <> "." :: Text)
|
|
app <- ask
|
|
void $ liftIO $ forkIO $ forkClient app
|
|
else do
|
|
logInfo $ display ("Tried to connect, but we are connected" :: Text)
|
|
return ()
|
|
-- TODO: show connection-status
|
|
cStatusText <- liftIO $ get (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus Text)
|
|
textColored (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus ImVec4) cStatusText
|
|
|
|
bracket_ (begin "Portfolio") end $ do
|
|
readTVarIO (currentAccount refs') >>= \case
|
|
Nothing -> text "No account selected"
|
|
Just aid -> do
|
|
accs <- liftIO $ readTVarIO $ Types.accounts data'
|
|
withTable defTableOptions "Portfolio" 6 $ \case
|
|
False -> return ()
|
|
True -> do
|
|
tableSetupColumn "Symbol"
|
|
tableSetupColumn "Position"
|
|
tableSetupColumn "Unrealized Profit"
|
|
tableSetupColumn "Realized Profit"
|
|
tableSetupColumn "AVG"
|
|
tableSetupColumn "Market Value"
|
|
tableHeadersRow
|
|
forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv ac up rp) ->
|
|
do
|
|
tableNextRow
|
|
tableNextColumn $ text $ localSymbol c
|
|
tableNextColumn $ text $ fromString $ show p
|
|
tableNextColumn $ text $ fromString $ show up
|
|
tableNextColumn $ text $ fromString $ show rp
|
|
tableNextColumn $ text $ fromString $ show mp
|
|
tableNextColumn $ text $ fromString $ show mv
|
|
|
|
bracket_ (begin "Search Symbols") end $ do
|
|
readTVarIO (currentAccount refs') >>= \case
|
|
Nothing -> text "No account selected"
|
|
Just _ -> do
|
|
let nextIDVar = nextValidID data'
|
|
sLookup = nextSymbolLookup data'
|
|
readTVarIO nextIDVar >>= \case
|
|
Nothing -> text "no id available, waiting ..."
|
|
Just i -> do
|
|
void $ inputText "Symbol-Lookup" (InjetiveGettable @Text @Text sLookup) 255
|
|
button "Lookup" >>= \case
|
|
False -> return ()
|
|
True ->
|
|
liftIO $ atomically $ do
|
|
readTVar sLookup >>= writeTQueue sendQ . Msg_IB_OUT . IB_RequestMatchingSymbol i
|
|
modifyTVar' nextIDVar (const Nothing)
|
|
withTable (defTableOptions { tableFlags = ImGuiTableFlags_SortMulti .|. ImGuiTableFlags_Sortable}) "Symbol" 5 $ \case
|
|
False -> return ()
|
|
True -> do
|
|
tableSetupColumn "Symbol"
|
|
tableSetupColumn "Security type"
|
|
tableSetupColumn "Primary exchange"
|
|
tableSetupColumn "Currency"
|
|
tableSetupColumn "Available derivatives"
|
|
withSortableTable $ \mustSort sortSpecs -> do
|
|
when mustSort $ liftIO $ pPrint sortSpecs
|
|
tableHeadersRow
|
|
lResult <- readTVarIO $ symbolLookupResults data'
|
|
forM_ lResult $ \contract@IBSymbolSample{..} -> do
|
|
let popupName = fromString $ "SymbolAction"<>show _symbolId
|
|
withPopup popupName $ \isPopupOpen -> do
|
|
when isPopupOpen $ do
|
|
button "creatChart" >>= \case
|
|
False -> return ()
|
|
True -> do
|
|
logInfo $ display $ "new chart open for: " <> _symbol
|
|
newChart $ def { conId = _symbolId, symbol = _symbol, secType = _secType, exchange = "SMART", primaryExchange = _primaryExchange, currency = _currency}
|
|
let printDatum x = tableNextColumn $ text $ x
|
|
tableNextRow
|
|
tableNextColumn $ do
|
|
void $ selectableWith (defSelectableOptions { flags = ImGuiSelectableFlags_SpanAllColumns }) _symbol
|
|
openPopupOnItemClick popupName ImGuiPopupFlags_MouseButtonRight
|
|
printDatum _secType
|
|
printDatum _primaryExchange
|
|
printDatum _currency
|
|
printDatum $ T.intercalate ", " _derivatives
|
|
|
|
-- chart windows
|
|
charts <- liftIO . readTVarIO . appCharts $ refs'
|
|
forM_ (HM.toList charts) $ \(symbol, cVar) -> do
|
|
bracket_ (begin symbol) end $ do
|
|
Chart{..} <- liftIO . readTVarIO $ cVar
|
|
case viewr chartData of
|
|
EmptyR -> text "no last price"
|
|
(_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay
|
|
withPlot "Test" $ do
|
|
-- TODO: set axes
|
|
let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
|
|
plotLine (T.unpack symbol) x y
|
|
return ()
|
|
return ()
|
|
|
|
|
|
-- Show the ImGui demo window
|
|
showDemoWindow
|
|
|
|
-- Show the ImPlot demo window
|
|
showPlotDemoWindow
|
|
|
|
-- Render
|
|
liftIO $ glClear GL_COLOR_BUFFER_BIT
|
|
|
|
render
|
|
liftIO $ openGL3RenderDrawData =<< getDrawData
|
|
|
|
liftIO $ glSwapWindow win
|
|
|
|
renderLoop
|