From befb1ab1eb9a5af10478226ec6e03dd0442de80e Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Mon, 14 Mar 2022 20:12:24 +0100 Subject: [PATCH] Init --- .gitignore | 8 + .gitmodules | 6 + .hlint.yaml | 0 ChangeLog.md | 3 + LICENSE | 30 ++ README.md | 10 + Setup.hs | 2 + app/Main.hs | 108 +++++++ deps/dear-imgui.hs | 1 + deps/dear-implot.hs | 1 + ibhelper.cabal | 248 ++++++++++++++++ package.yaml | 121 ++++++++ src/AppFiller.hs | 79 +++++ src/Chart.hs | 89 ++++++ src/IBClient/Connection.hs | 95 ++++++ src/IBClient/Types.hs | 581 +++++++++++++++++++++++++++++++++++++ src/Import.hs | 16 + src/Run.hs | 230 +++++++++++++++ src/Types.hs | 240 +++++++++++++++ src/Util.hs | 11 + stack.yaml | 79 +++++ test/Spec.hs | 1 + test/UtilSpec.hs | 14 + 23 files changed, 1973 insertions(+) create mode 100644 .gitignore create mode 100644 .gitmodules create mode 100644 .hlint.yaml create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 160000 deps/dear-imgui.hs create mode 160000 deps/dear-implot.hs create mode 100644 ibhelper.cabal create mode 100644 package.yaml create mode 100644 src/AppFiller.hs create mode 100644 src/Chart.hs create mode 100644 src/IBClient/Connection.hs create mode 100644 src/IBClient/Types.hs create mode 100644 src/Import.hs create mode 100644 src/Run.hs create mode 100644 src/Types.hs create mode 100644 src/Util.hs create mode 100644 stack.yaml create mode 100644 test/Spec.hs create mode 100644 test/UtilSpec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..aed424b --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +*~ +*.swp +tarballs/ +.stack-work/ +imgui.ini +settings.json +*.lock +tags diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..8734bca --- /dev/null +++ b/.gitmodules @@ -0,0 +1,6 @@ +[submodule "deps/dear-implot.hs"] + path = deps/dear-implot.hs + url = https://github.com/Drezil/dear-implot.hs +[submodule "deps/dear-imgui.hs"] + path = deps/dear-imgui.hs + url = https://github.com/haskell-game/dear-imgui.hs diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..e69de29 diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..46aa496 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for ibhelper + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..341f6e7 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Stefan Dresselhaus (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE 2022 Stefan Dresselhaus HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 2022 Stefan Dresselhaus +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..63fc31f --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# ibhelper + +## Execute + +* Run `stack exec -- ibhelper-exe` to see "We're inside the application!" +* With `stack exec -- ibhelper-exe --verbose` you will see the same message, with more logging. + +## Run tests + +`stack test` diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..ac2a3a7 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +module Main (main) where + +import Import +import Data.Aeson (eitherDecodeFileStrict') +import Control.Monad.Managed +import Control.Concurrent +import DearImGui +import DearImGui.OpenGL3 +import DearImGui.GLFW +import DearImGui.GLFW.OpenGL +import Run +import RIO.Process +import System.Directory +import Options.Applicative.Simple +import qualified Paths_ibhelper +import qualified Graphics.UI.GLFW as GLFW +import qualified Data.Text as T +import Prelude (putStrLn) +import AppFiller + + +main :: IO () +main = do + (options, ()) <- simpleOptions + $(simpleVersion Paths_ibhelper.version) + "Header for command line arguments" + "Program description, also for command line arguments" + (Options + <$> switch ( long "verbose" + <> short 'v' + <> help "Verbose output?" + ) + ) + empty + settingsFileExists <- doesFileExist "settings.json" + settings <- if settingsFileExists + then do + s <- fmap unDefaultJSON <$> eitherDecodeFileStrict' "settings.json" + pPrint s + case s of + Left e -> putStrLn ("Error loading settings: \n"<>e) >> return def + Right s' -> return s' + else return def + lo <- logOptionsHandle stderr (optionsVerbose options) + <&> setLogMinLevel (settings ^. logLevel) + <&> setLogTerminal True + pc <- mkDefaultProcessContext + withLogFunc lo $ \lf -> do + -- let bare_log = unLogFunc $ view logFuncL lf + -- logErr = liftIO . bare_log callStack "" LevelError + initialized <- GLFW.init + unless initialized $ error "GLFW init failed" + + liftIO $ runManaged $ do + mwin <- managed $ bracket + (GLFW.createWindow (settings ^. windowParams . windowWidth) (settings ^. windowParams . windowHeight) "IB-Helper" Nothing Nothing) + (maybe (return ()) GLFW.destroyWindow) + case mwin of + Just win -> do + liftIO $ do + GLFW.makeContextCurrent (Just win) + GLFW.swapInterval 1 + + -- Create an ImGui context + _ <- managed $ bracket createContext destroyContext + + -- Create an ImPlot context + -- _ <- managed $ bracket createPlotContext destroyPlotContext + + -- Initialize ImGui's GLFW backend + _ <- managed_ $ bracket_ (glfwInitForOpenGL win True) glfwShutdown + + -- Initialize ImGui's OpenGL backend + _ <- managed_ $ bracket_ openGL3Init openGL3Shutdown + + twsConnectionRefsHost <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . host . to T.unpack + twsConnectionRefsPort <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . port . to T.unpack + twsConnectionStatus <- liftIO $ atomically $ newTVar $ TWSDisconnected + twsConnectionSend <- liftIO $ atomically $ newTQueue + twsConnectionRecieve <- liftIO $ atomically $ newTQueue + let twsConnectionRefs = TWSConnectionRefs{..} + liftIO $ atomically $ writeTQueue twsConnectionSend $ Msg_IB_OUT $ IB_RequestMarketDataType DelayedFrozen + currentAccount <- liftIO $ newTVarIO $ Nothing + tickerIdToSymbol <- liftIO $ newTVarIO $ mempty + appCharts <- liftIO $ newTVarIO $ mempty + appData <- liftIO $ DataRefs + <$> newTVarIO mempty + <*> newTVarIO Nothing + <*> newTVarIO mempty + <*> newTVarIO mempty + let app = App + { appSettings = settings + , appLogFunc = lf + , appProcessContext = pc + , appOptions = options + , appWindow = win + , appRefs = AppRefs{..} + , appData = appData + } + void $ liftIO $ forkIO $ appFiller app + liftIO $ runRIO app run + Nothing -> do + error "GLFW createWindow failed" + + GLFW.terminate + diff --git a/deps/dear-imgui.hs b/deps/dear-imgui.hs new file mode 160000 index 0000000..e5969f6 --- /dev/null +++ b/deps/dear-imgui.hs @@ -0,0 +1 @@ +Subproject commit e5969f6b358dab01d9e2bea8d3538fdfbee0c2f1 diff --git a/deps/dear-implot.hs b/deps/dear-implot.hs new file mode 160000 index 0000000..78f7df0 --- /dev/null +++ b/deps/dear-implot.hs @@ -0,0 +1 @@ +Subproject commit 78f7df091ceb88f57eaacdb0a1e2d43cbce04566 diff --git a/ibhelper.cabal b/ibhelper.cabal new file mode 100644 index 0000000..7a138fd --- /dev/null +++ b/ibhelper.cabal @@ -0,0 +1,248 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: ibhelper +version: 0.1.0.0 +description: Please see the README.md +homepage: https://github.com/Drezil/ibhelper#readme +bug-reports: https://github.com/Drezil/ibhelper/issues +author: Stefan Dresselhaus +maintainer: sdressel@pwning.de +copyright: 2022 Stefan Dresselhaus +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/Drezil/ibhelper + +library + exposed-modules: + AppFiller + Chart + IBClient.Connection + IBClient.Types + Import + Run + Types + Util + other-modules: + Paths_ibhelper + hs-source-dirs: + src + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + DuplicateRecordFields + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + GLFW-b + , StateVar + , aeson + , base >=4.11 && <10 + , binary + , bytestring + , data-default + , dear-imgui + , directory + , fingertree + , gl + , managed + , microlens-th + , network + , pretty-show + , rio >=0.1.12.0 + , stm + , text + , time + , type-iso + , unordered-containers + default-language: Haskell2010 + +executable ibhelper-exe + main-is: Main.hs + other-modules: + Paths_ibhelper + hs-source-dirs: + app + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + DuplicateRecordFields + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + GLFW-b + , StateVar + , aeson + , base >=4.11 && <10 + , binary + , bytestring + , data-default + , dear-imgui + , directory + , fingertree + , gl + , ibhelper + , managed + , microlens-th + , network + , optparse-simple + , pretty-show + , rio >=0.1.12.0 + , stm + , text + , time + , type-iso + , unordered-containers + default-language: Haskell2010 + +test-suite ibhelper-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + UtilSpec + Paths_ibhelper + hs-source-dirs: + test + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + DuplicateRecordFields + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + GLFW-b + , StateVar + , aeson + , base >=4.11 && <10 + , binary + , bytestring + , data-default + , dear-imgui + , directory + , fingertree + , gl + , hspec + , ibhelper + , managed + , microlens-th + , network + , pretty-show + , rio >=0.1.12.0 + , stm + , text + , time + , type-iso + , unordered-containers + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..ba96f63 --- /dev/null +++ b/package.yaml @@ -0,0 +1,121 @@ +name: ibhelper +version: 0.1.0.0 +github: Drezil/ibhelper +license: BSD3 +author: Stefan Dresselhaus +maintainer: sdressel@pwning.de +copyright: 2022 Stefan Dresselhaus + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README.md + +default-extensions: + - BangPatterns + - BinaryLiterals + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveDataTypeable + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DoAndIfThenElse + - EmptyDataDecls + - ExistentialQuantification + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - InstanceSigs + - KindSignatures + - LambdaCase + - MultiParamTypeClasses + - MultiWayIf + - NamedFieldPuns + - NoImplicitPrelude + - OverloadedStrings + - PartialTypeSignatures + - PatternGuards + - PolyKinds + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeFamilies + - TypeSynonymInstances + - ViewPatterns + - DuplicateRecordFields + +dependencies: +- base >= 4.11 && < 10 +- rio >= 0.1.12.0 +- dear-imgui +- GLFW-b +- managed +- gl +- aeson +- data-default +- directory +- microlens-th +- network +- bytestring +- stm +- text +- pretty-show +- StateVar +- type-iso +- binary +- time +- unordered-containers +- fingertree + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wpartial-fields +- -Wredundant-constraints + +library: + source-dirs: src + +executables: + ibhelper-exe: + main: Main.hs + source-dirs: app + dependencies: + - ibhelper + - optparse-simple + + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + +tests: + ibhelper-test: + main: Spec.hs + source-dirs: test + dependencies: + - ibhelper + - hspec + + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N diff --git a/src/AppFiller.hs b/src/AppFiller.hs new file mode 100644 index 0000000..fcdb9fc --- /dev/null +++ b/src/AppFiller.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +module AppFiller where + +import Import +import Types + +import qualified Data.Text as T + +import Data.Time +import Data.FingerTree +import Data.HashMap.Strict ((!?)) +import qualified Data.HashMap.Strict as HM + + +import qualified Debug.Trace as D + +appFiller :: App -> IO () +appFiller app = runRIO app $ withRunInIO $ \run -> do + let queue = twsConnectionRecieve . twsConnectionRefs . appRefs $ app + debugMsg x = run $ logDebug (display $ T.pack $ "FILLER : " <> T.unpack x) + infoMsg x = run $ logDebug (display $ T.pack $ "FILLER : " <> T.unpack x) + forever $ do + input <- atomically $ readTQueue queue + let currentAppData = appData app + case input of + (Msg_IB_IN IB_PositionData) -> return () + (Msg_IB_IN (IB_ManagedAccts as)) -> do + cur <- readTVarIO $ Types.accounts currentAppData + actions <- forM as $ \a -> case cur !? a of + Just _ -> return $ id + Nothing -> do + debugMsg $ "added Account "<> a + return $ HM.insertWith const a (mkIBAccount a) + atomically $ modifyTVar (Types.accounts currentAppData) $ foldl' (.) id actions + (Msg_IB_IN (IB_NextValidID i)) -> atomically $ modifyTVar' (nextValidID currentAppData) (const (Just i)) + (Msg_IB_IN (IB_ErrorMsg i c m)) -> debugMsg "IB_ErrorMsg not implemented" + (Msg_IB_IN (IB_AccountValue k v c n)) -> do + let action = HM.update (\ai -> Just $ ai & accountInfo . accountProperties %~ HM.alter (\old -> Just $ (v,c):filter ((/=c) . snd) (fromMaybe [] old)) k) n + atomically $ modifyTVar' (Types.accounts currentAppData) action + (Msg_IB_IN (IB_AccountUpdateTime t)) -> debugMsg "IB_AccountUpdateTime not implemented" + -- (Msg_IB_IN (IB_AccountUpdateTime t)) -> do + -- let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n + -- atomically $ modifyTVar' (Types.accounts currentAppData) action + (Msg_IB_IN (IB_PortfolioValue c p mp mv ac u r n)) -> do + let cid = conId :: IBContract -> Int + updateAction (a@IBPortfolioValue{..}:as) + | cid _contract == cid c = IBPortfolioValue c p mp mv ac u r:as + | otherwise = a:updateAction as + updateAction [] = [IBPortfolioValue c p mp mv ac u r] + action = HM.update (\ai -> Just $ ai & accountPortfolio %~ updateAction) n + atomically $ modifyTVar' (Types.accounts currentAppData) action + (Msg_IB_IN (IB_SymbolSamples r s)) -> do + atomically $ do + modifyTVar' (nextValidID currentAppData) (const $ Just r) + modifyTVar' (symbolLookupResults currentAppData) (const $ (\IB_SymbolSample{..} -> IBSymbolSample symId symbol secType primaryExchange currency derivatives) <$> s) + (Msg_IB_IN t@IB_TickPrice{}) -> run $ handleTickPrice t + _ -> --D.trace ("not implemented in AppFiller:" <> show input) $ + infoMsg $ "not implemented in AppFiller:" <> T.pack (show input) + + +handleTickPrice :: IB_IN -> RIO App () +handleTickPrice IB_TickPrice{..} = do + charts <- appCharts . appRefs <$> ask + tid2symbol <- tickerIdToSymbol . appRefs <$> ask + msymbol <- (HM.!? tickerId) <$> liftIO (readTVarIO tid2symbol) + case msymbol of + Nothing -> return () --ignore + Just s -> do + chartVar <- (HM.!s) <$> liftIO (readTVarIO charts) + case tickType of + IBTickType_Last_Price -> do + t <- utctDayTime <$> liftIO getCurrentTime + let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price [] + liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True}) + _ -> return () +handleTickPrice _ = error "impossible" + + diff --git a/src/Chart.hs b/src/Chart.hs new file mode 100644 index 0000000..670c45a --- /dev/null +++ b/src/Chart.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DerivingVia #-} +module Chart (newChart, FillerException(..)) where + +import Import +import Data.Time +import RIO.List +import RIO.List.Partial +import Data.FingerTree (FingerTree) +import Control.Concurrent (forkIO) +import qualified RIO.ByteString as BS +-- import Control.Exception +import qualified Data.HashMap.Strict as HM +import qualified Data.FingerTree as FT + +import qualified Debug.Trace as D + +data FillerException = QuitFiller + deriving Show + +instance Exception FillerException + +deriving via Integer instance Hashable Day + +newChart :: IBContract -> RIO App () +newChart contract = do + app <- ask + let sym = (symbol :: IBContract -> Text) contract + hmVar = appCharts . appRefs $ app + hm <- liftIO . readTVarIO $ hmVar + unless (sym `HM.member` hm) $ do + c <- liftIO $ newTVarIO $ Chart FT.empty mempty undefined defChartSettings [] Nothing False + tid <- liftIO $ forkIO $ fillChart app contract c + liftIO $ atomically $ do + modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..}) + modifyTVar' hmVar (HM.insert sym c) + +fillChart :: App -> IBContract -> TVar Chart -> IO () +fillChart app contract cVar = runRIO app $ do + let sym = (symbol :: IBContract -> Text) contract + (tickerMapVar :: TVar (HashMap Int Text)) <- tickerIdToSymbol. appRefs <$> ask + alreadyAdded <- (sym `elem`) . HM.elems <$> liftIO (readTVarIO tickerMapVar) + unless alreadyAdded $ do + tickerId <- (+1) . foldl' max 1000 . HM.keys <$> liftIO (readTVarIO tickerMapVar) + let cancelSubscription = liftIO $ atomically $ do + modifyTVar tickerMapVar (HM.delete tickerId) + -- TODO: send cancel-request + let sendQ = twsConnectionSend $ twsConnectionRefs $ appRefs $ app + liftIO $ atomically $ do + modifyTVar tickerMapVar (HM.insert tickerId sym) + writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False + handle (\QuitFiller -> cancelSubscription >> exitSuccess) $ + forever $ do + -- chart dirty? set clean & begin work + Chart{..} <- liftIO (readTVarIO cVar) + when chartDirty $ do + liftIO $ atomically $ modifyTVar cVar (\c -> c { chartDirty = False }) + let (TimePoint cacheUpdateStart) = fromMaybe (TimePoint 0) Nothing -- TODO: lastCacheUpdate + cacheUpdateEnd = 86400 + chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])] + chunkChart from until range tree = go from range interval + where + lastItem = case FT.viewr interval of + FT.EmptyR -> until + (_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay + interval = FT.takeUntil (\(TimePoint x) -> x > until) + . FT.dropUntil (\(TimePoint x) -> x > from) + $ tree + go f i t + | f+i >= lastItem = [(TimePoint (f+i), toList t)] + | otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t + in (TimePoint (f+i),toList a) : go (f+i) i b + chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution chartSettings) chartData + cachePoints = takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart + toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint + toCachePoint (t,[]) = ChartPoint t (-1) [] + toCachePoint (t,as) = ChartPoint t c [OLHC o l h c] + where + as' = pointValue <$> as + o = head as' + c = last as' + l = minimum as' + h = maximum as' + let lUpdate = fmap fst . lastMaybe $ chunkedChart + liftIO $ atomically $ modifyTVar cVar (\c -> c { chartCache = cachePoints, lastCacheUpdate = lUpdate }) + return () + threadDelay 1000000 -- sleep 5 seconds diff --git a/src/IBClient/Connection.hs b/src/IBClient/Connection.hs new file mode 100644 index 0000000..60292b5 --- /dev/null +++ b/src/IBClient/Connection.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TypeApplications #-} +module IBClient.Connection where + +import Import + +import Data.Binary +import Network.Socket +import Network.Socket.ByteString + +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text as T + +forkClient :: App -> IO () +forkClient app = runRIO app $ withRunInIO $ \run -> withSocketsDo $ do + let refs = twsConnectionRefs $ appRefs app + toSend = twsConnectionSend refs + toRecieve = twsConnectionRecieve refs + cStatus = twsConnectionStatus refs + debugSend x = run $ logDebug (display $ T.pack $ "SENT : " <> show x) + debugRecv x = run $ logDebug (display $ T.pack $ "RECIEVED: " <> show x) + connHost <- readTVarIO $ twsConnectionRefsHost refs + connPort <- readTVarIO $ twsConnectionRefsPort refs + atomically $ modifyTVar' cStatus (const TWSConnecting) + -- TODO: throws IO-Exeption instead of returning empty list -> handle! + addr:_ <- getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrProtocol = 0, addrSocketType = Stream}) (Just connHost) (Just connPort) + run $ logDebug $ displayShow addr + E.bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close $ \sock -> do + connect sock $ addrAddress addr + let connStr = BS8.pack "API\0\0\0\0\tv100..157" + sendAll sock connStr + debugSend connStr + answer <- recvAll sock + run $ logDebug (displayShow (decode . LBS.fromStrict <$> answer :: Maybe IBGenericMessage)) + -- if we have the answer we are connected + let idStr = LBS.toStrict $ encode $ IB_StartAPI "2" "69" -- version 2, client-id: 69 + sendAll sock idStr + debugSend idStr + atomically $ modifyTVar' cStatus (const TWSConnected) + run $ logInfo $ display ("Connected to TWS" :: Text) + let go True = do + -- abort connection, close everything + return () + go False = do + -- race: wait for MSG in Queue or for answer on socket + input <- race (atomically $ readTQueue toSend) + (recvAll sock) + case input of + -- we want to disconnect + Left IBDisconnect -> go True + Left (Msg_IB_OUT x) -> do + let msg = LBS.toStrict $ encode x + debugSend msg + sendAll sock msg + -- we lost connection + Right Nothing -> do + atomically $ do + writeTQueue toRecieve IBServerGone + modifyTVar' cStatus (const TWSDisconnected) + run $ logWarn $ display $ T.pack "Lost connection to TWS, reconnecting..." + forkClient app + Right (Just x) -> do debugRecv x + parseMessage x + where + parseMessage "" = return () + parseMessage m = do + let d = decodeOrFail @IB_IN (LBS.fromStrict m) + case d of + Right (rest, offset, result) -> do + atomically $ writeTQueue toRecieve (Msg_IB_IN result) + parseMessage (LBS.toStrict rest) + Left (rest, offset, err) -> do + run $ logInfo (display $ T.pack $ "Could not understand message: "<> ppShow err <> " ... skipping.\nRAW: " <> show m) + if m == "\NUL" then do + run $ logInfo (display $ T.pack "killing NUL") + parseMessage (LBS.toStrict $ LBS.tail rest) + else + parseMessage (LBS.toStrict rest) + go False + go False + + +recvAll :: Socket -> IO (Maybe ByteString) +recvAll s = do + d <- recv s 4096 + let l = BS.length d + if + | l == 0 -> return Nothing + | l < 4096 -> return $ Just d + | l == 4096 -> do + next <- recvAll s + return $ (d<>) <$> next + | otherwise -> error "recvAll: recv got more bytes then requested. Impossible according to RFC" diff --git a/src/IBClient/Types.hs b/src/IBClient/Types.hs new file mode 100644 index 0000000..ef4ea47 --- /dev/null +++ b/src/IBClient/Types.hs @@ -0,0 +1,581 @@ +{-# HLINT ignore "Use camelCase" #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} +module IBClient.Types where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Text.Encoding +import Data.Maybe +import Data.Default +import Data.Aeson (FromJSON, ToJSON) +import GHC.Enum (Enum(..)) +import RIO +import RIO.List +import RIO.List.Partial +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 + + +import qualified Debug.Trace as D + +data Msg_IB_OUT = IBDisconnect + | Msg_IB_OUT IB_OUT + deriving (Show, Eq) + +data Msg_IB_IN = IBServerGone + | Msg_IB_IN IB_IN + deriving (Show, Eq) + +data IBTypes = IBString ByteString + | IBBool Bool + | IBArray [ByteString] + deriving (Show, Eq) + +toBS :: IBTypes -> ByteString +toBS (IBString t) = t +toBS (IBArray a) = (BS8.pack . show . length $ a) <> BS.intercalate "\0" a <> "\0" +toBS (IBBool True) = "1"--BS.pack [0,0,0,1] -- bool == 32-bit int in IB +toBS (IBBool False) = "0"--BS.pack [0,0,0,0] -- bool == 32-bit int in IB + +newtype IBGenericMessage = IBGenericMessage + { fields :: [IBTypes] + } deriving (Show, Eq) + +instance Binary IBGenericMessage where + put (IBGenericMessage f) = do + let msg = BS.intercalate "\0" (toBS <$> f) <> "\0" + putWord32be . fromIntegral . BS.length $ msg + putByteString msg + get = do + len <- getWord32be + D.traceShow len $ return () + fields <- BS.split 0 . BS.init <$> getByteString (fromIntegral len) + D.traceShow fields $ return () + return $ IBGenericMessage $ IBString <$> fields + +data IB_OUT = IB_StartAPI { version :: Text, clientId :: Text } + | IB_RequestPositions + | IB_RequestAccountData { subscribe :: Bool, acctCode :: Text } + | IB_RequestMatchingSymbol { reqId :: Int, symbol :: Text } + | IB_RequestMarketDataType { dataType :: IBMarketDataType } + | IB_RequestMktData { tickerId :: Int, contract :: IBContract, genericTickList :: Text, snapshot :: Bool, regulatorySnapshot :: Bool } + deriving (Show, Eq) + +tToIB :: Text -> IBTypes +tToIB = IBString . encodeUtf8 + +iToIB :: Int -> IBTypes +iToIB = IBString . BS8.pack . show + +fToIB :: Float -> IBTypes +fToIB = IBString . BS8.pack . show + +clToIB :: [IBComboLeg] -> [IBTypes] +clToIB as = iToIB (length as) : concatMap (\IBComboLeg{..} -> [iToIB conId, iToIB ratio, tToIB action, tToIB exchange]) as + +dncToIB :: Maybe IBDeltaNeutralContract -> [IBTypes] +dncToIB Nothing = [] +dncToIB (Just IBDeltaNeutralContract{..}) = [iToIB 1, iToIB conId, fToIB delta, fToIB price] + +instance Binary IB_OUT where + put (IB_StartAPI v c) = put (IBGenericMessage [IBString "71", tToIB v, tToIB c, IBString ""]) + put IB_RequestPositions = put (IBGenericMessage [IBString "61", IBString "v"]) + put (IB_RequestAccountData s a) = put (IBGenericMessage [IBString "6", IBString "2", IBBool s, tToIB a]) + put (IB_RequestMatchingSymbol i s) = put (IBGenericMessage [IBString "81", iToIB i, tToIB s]) + put (IB_RequestMktData t IBContract{..} l s r) = put $ D.traceShowId (IBGenericMessage $ [IBString "1", IBString "11", iToIB t, iToIB conId, tToIB symbol, tToIB secType, tToIB lastTradeDate, fToIB strike, tToIB right, tToIB multiplier, tToIB exchange, tToIB primaryExchange, tToIB currency, tToIB localSymbol, tToIB tradingClass] <> clToIB comboLegs <> dncToIB deltaNeutralContract <> [tToIB l, iToIB (if s then 1 else 0), iToIB (if r then 1 else 0), tToIB ""]) + put (IB_RequestMarketDataType t) = put (IBGenericMessage [IBString "59", IBString "1", iToIB $ fromEnum t]) + + get = do f <- fmap (\(IBString x) -> x) . fields <$> get + case headMaybe f of + Just "71" -> return $ IB_StartAPI (decodeUtf8 $ f!!1) (decodeUtf8 $ f!!2) + Just "6" -> return $ IB_RequestAccountData {- ignore version -} (all (==0) . BS.unpack $ f!!2) (decodeUtf8 $ f!!3) + Just "59" -> return $ IB_RequestMarketDataType {- ignore version -} (toEnum . fromJust . readMaybe . BS8.unpack $ f!!2) + Just x -> fail $ "unkonwn IB_OUT type" <> BS8.unpack x + Nothing -> fail $ "No Fields" + +data IBContract = IBContract + { conId :: Int + , symbol :: Text + , secType :: Text + , lastTradeDate :: Text + , strike :: Float + , right :: Text + , multiplier :: Text + , exchange :: Text -- ^ can be SMART + , primaryExchange :: Text -- ^ actual exchange - MUST NOT BE SMART + , currency :: Text + , localSymbol :: Text + , tradingClass :: Text + , includeExpired :: Bool + , secIdType :: Text + , secId :: Text + , comboLegsDescrip :: Text -- ^ received in open order 14 and up for all combos + , comboLegs :: [IBComboLeg] + , deltaNeutralContract :: Maybe IBDeltaNeutralContract + } deriving (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Default IBContract where + def = IBContract 0 "" "" "" 0 "" "" "" "" "" "" "" False "" "" "" [] Nothing + +data IBComboLeg = IBComboLeg + { conId :: Int + , ratio :: Int + , action :: Text -- ^ BUY/SELL/SSHORT + , exchange :: Text + , openClose :: Int -- ^ LegOpenClose enum values + , shortSaleSlot :: Int + , designatedLocation :: Text + , exemptCode :: Int + } deriving (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Default IBComboLeg where + def = IBComboLeg 0 0 "" "" 0 0 "" (negate 1) + +data IBDeltaNeutralContract = IBDeltaNeutralContract + { conId :: Int + , delta :: Float + , price :: Float + } deriving (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Default IBDeltaNeutralContract where + def = IBDeltaNeutralContract 0 0 0 + +data IBMarketDataType = RealTime + | Frozen + | Delayed + | DelayedFrozen + deriving (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Default IBMarketDataType where + def = DelayedFrozen + +instance Enum IBMarketDataType where + toEnum 1 = RealTime + toEnum 2 = Frozen + toEnum 3 = Delayed + toEnum 4 = DelayedFrozen + toEnum _ = def + fromEnum RealTime = 1 + fromEnum Frozen = 2 + fromEnum Delayed = 3 + fromEnum DelayedFrozen = 4 + +data IBTickType = Unknown Int + | IBTickType_Bid_Size + | IBTickType_Bid_Price + | IBTickType_Ask_Price + | IBTickType_Ask_Size + | IBTickType_Last_Price + | IBTickType_Last_Size + | IBTickType_High + | IBTickType_Low + | IBTickType_Volume + | IBTickType_Close_Price + | IBTickType_Bid_Option_Computation + | IBTickType_Ask_Option_Computation + | IBTickType_Last_Option_Computation + | IBTickType_Model_Option_Computation + | IBTickType_Open_Tick + | IBTickType_Low_13_Weeks + | IBTickType_High_13_Weeks + | IBTickType_Low_26_Weeks + | IBTickType_High_26_Weeks + | IBTickType_Low_52_Weeks + | IBTickType_High_52_Weeks + | IBTickType_Average_Volume + | IBTickType_Open_Interest + | IBTickType_Option_Historical_Volatility + | IBTickType_Option_Implied_Volatility + | IBTickType_Option_Bid_Exchange + | IBTickType_Option_Ask_Exchange + | IBTickType_Option_Call_Open_Interest + | IBTickType_Option_Put_Open_Interest + | IBTickType_Option_Call_Volume + | IBTickType_Option_Put_Volume + | IBTickType_Index_Future_Premium + | IBTickType_Bid_Exchange + | IBTickType_Ask_Exchange + | IBTickType_Auction_Volume + | IBTickType_Auction_Price + | IBTickType_Auction_Imbalance + | IBTickType_Mark_Price + | IBTickType_Bid_EFP_Computation + | IBTickType_Ask_EFP_Computation + | IBTickType_Last_EFP_Computation + | IBTickType_Open_EFP_Computation + | IBTickType_High_EFP_Computation + | IBTickType_Low_EFP_Computation + | IBTickType_Close_EFP_Computation + | IBTickType_Last_Timestamp + | IBTickType_Shortable + | IBTickType_RT_Volume + | IBTickType_Halted + | IBTickType_Bid_Yield + | IBTickType_Ask_Yield + | IBTickType_Last_Yield + | IBTickType_Custom_Option_Computation + | IBTickType_Trade_Count + | IBTickType_Trade_Rate + | IBTickType_Volume_Rate + | IBTickType_Last_RTH_Trade + | IBTickType_RT_Historical_Volatility + | IBTickType_IB_Dividends + | IBTickType_Bond_Factor_Multiplier + | IBTickType_Regulatory_Imbalance + | IBTickType_News + | IBTickType_ShortTerm_Volume_3_Minutes + | IBTickType_ShortTerm_Volume_5_Minutes + | IBTickType_ShortTerm_Volume_10_Minutes + | IBTickType_Delayed_Bid + | IBTickType_Delayed_Ask + | IBTickType_Delayed_Last + | IBTickType_Delayed_Bid_Size + | IBTickType_Delayed_Ask_Size + | IBTickType_Delayed_Last_Size + | IBTickType_Delayed_High_Price + | IBTickType_Delayed_Low_Price + | IBTickType_Delayed_Volume + | IBTickType_Delayed_Close + | IBTickType_Delayed_Open + | IBTickType_RT_Trade_Volume + | IBTickType_Creditman_mark_price + | IBTickType_Creditman_slow_mark_price + | IBTickType_Delayed_Bid_Option + | IBTickType_Delayed_Ask_Option + | IBTickType_Delayed_Last_Option + | IBTickType_Delayed_Model_Option + | IBTickType_Last_Exchange + | IBTickType_Last_Regulatory_Time + | IBTickType_Futures_Open_Interest + | IBTickType_Average_Option_Volume + | IBTickType_Delayed_Last_Timestamp + | IBTickType_Shortable_Shares + | IBTickType_ETF_Nav_Close + | IBTickType_ETF_Nav_Prior_Close + | IBTickType_ETF_Nav_Bid + | IBTickType_ETF_Nav_Ask + | IBTickType_ETF_Nav_Last + | IBTickType_ETF_Nav_Frozen_Last + | IBTickType_ETF_Nav_High + | IBTickType_ETF_Nav_Low + deriving (Show, Eq) + +instance Enum IBTickType where + toEnum 0 = IBTickType_Bid_Size + toEnum 1 = IBTickType_Bid_Price + toEnum 2 = IBTickType_Ask_Price + toEnum 3 = IBTickType_Ask_Size + toEnum 4 = IBTickType_Last_Price + toEnum 5 = IBTickType_Last_Size + toEnum 6 = IBTickType_High + toEnum 7 = IBTickType_Low + toEnum 8 = IBTickType_Volume + toEnum 9 = IBTickType_Close_Price + toEnum 10 = IBTickType_Bid_Option_Computation + toEnum 11 = IBTickType_Ask_Option_Computation + toEnum 12 = IBTickType_Last_Option_Computation + toEnum 13 = IBTickType_Model_Option_Computation + toEnum 14 = IBTickType_Open_Tick + toEnum 15 = IBTickType_Low_13_Weeks + toEnum 16 = IBTickType_High_13_Weeks + toEnum 17 = IBTickType_Low_26_Weeks + toEnum 18 = IBTickType_High_26_Weeks + toEnum 19 = IBTickType_Low_52_Weeks + toEnum 20 = IBTickType_High_52_Weeks + toEnum 21 = IBTickType_Average_Volume + toEnum 22 = IBTickType_Open_Interest + toEnum 23 = IBTickType_Option_Historical_Volatility + toEnum 24 = IBTickType_Option_Implied_Volatility + toEnum 25 = IBTickType_Option_Bid_Exchange + toEnum 26 = IBTickType_Option_Ask_Exchange + toEnum 27 = IBTickType_Option_Call_Open_Interest + toEnum 28 = IBTickType_Option_Put_Open_Interest + toEnum 29 = IBTickType_Option_Call_Volume + toEnum 30 = IBTickType_Option_Put_Volume + toEnum 31 = IBTickType_Index_Future_Premium + toEnum 32 = IBTickType_Bid_Exchange + toEnum 33 = IBTickType_Ask_Exchange + toEnum 34 = IBTickType_Auction_Volume + toEnum 35 = IBTickType_Auction_Price + toEnum 36 = IBTickType_Auction_Imbalance + toEnum 37 = IBTickType_Mark_Price + toEnum 38 = IBTickType_Bid_EFP_Computation + toEnum 39 = IBTickType_Ask_EFP_Computation + toEnum 40 = IBTickType_Last_EFP_Computation + toEnum 41 = IBTickType_Open_EFP_Computation + toEnum 42 = IBTickType_High_EFP_Computation + toEnum 43 = IBTickType_Low_EFP_Computation + toEnum 44 = IBTickType_Close_EFP_Computation + toEnum 45 = IBTickType_Last_Timestamp + toEnum 46 = IBTickType_Shortable + toEnum 48 = IBTickType_RT_Volume + toEnum 49 = IBTickType_Halted + toEnum 50 = IBTickType_Bid_Yield + toEnum 51 = IBTickType_Ask_Yield + toEnum 52 = IBTickType_Last_Yield + toEnum 53 = IBTickType_Custom_Option_Computation + toEnum 54 = IBTickType_Trade_Count + toEnum 55 = IBTickType_Trade_Rate + toEnum 56 = IBTickType_Volume_Rate + toEnum 57 = IBTickType_Last_RTH_Trade + toEnum 58 = IBTickType_RT_Historical_Volatility + toEnum 59 = IBTickType_IB_Dividends + toEnum 60 = IBTickType_Bond_Factor_Multiplier + toEnum 61 = IBTickType_Regulatory_Imbalance + toEnum 62 = IBTickType_News + toEnum 63 = IBTickType_ShortTerm_Volume_3_Minutes + toEnum 64 = IBTickType_ShortTerm_Volume_5_Minutes + toEnum 65 = IBTickType_ShortTerm_Volume_10_Minutes + toEnum 66 = IBTickType_Delayed_Bid + toEnum 67 = IBTickType_Delayed_Ask + toEnum 68 = IBTickType_Delayed_Last + toEnum 69 = IBTickType_Delayed_Bid_Size + toEnum 70 = IBTickType_Delayed_Ask_Size + toEnum 71 = IBTickType_Delayed_Last_Size + toEnum 72 = IBTickType_Delayed_High_Price + toEnum 73 = IBTickType_Delayed_Low_Price + toEnum 74 = IBTickType_Delayed_Volume + toEnum 75 = IBTickType_Delayed_Close + toEnum 76 = IBTickType_Delayed_Open + toEnum 77 = IBTickType_RT_Trade_Volume + toEnum 78 = IBTickType_Creditman_mark_price + toEnum 79 = IBTickType_Creditman_slow_mark_price + toEnum 80 = IBTickType_Delayed_Bid_Option + toEnum 81 = IBTickType_Delayed_Ask_Option + toEnum 82 = IBTickType_Delayed_Last_Option + toEnum 83 = IBTickType_Delayed_Model_Option + toEnum 84 = IBTickType_Last_Exchange + toEnum 85 = IBTickType_Last_Regulatory_Time + toEnum 86 = IBTickType_Futures_Open_Interest + toEnum 87 = IBTickType_Average_Option_Volume + toEnum 88 = IBTickType_Delayed_Last_Timestamp + toEnum 89 = IBTickType_Shortable_Shares + toEnum 92 = IBTickType_ETF_Nav_Close + toEnum 93 = IBTickType_ETF_Nav_Prior_Close + toEnum 94 = IBTickType_ETF_Nav_Bid + toEnum 95 = IBTickType_ETF_Nav_Ask + toEnum 96 = IBTickType_ETF_Nav_Last + toEnum 97 = IBTickType_ETF_Nav_Frozen_Last + toEnum 98 = IBTickType_ETF_Nav_High + toEnum 99 = IBTickType_ETF_Nav_Low + toEnum x = D.trace ("Unknown tick-type-id: " <> show x) $ Unknown x + fromEnum (Unknown x) = x + fromEnum IBTickType_Bid_Size = 0 + fromEnum IBTickType_Bid_Price = 1 + fromEnum IBTickType_Ask_Price = 2 + fromEnum IBTickType_Ask_Size = 3 + fromEnum IBTickType_Last_Price = 4 + fromEnum IBTickType_Last_Size = 5 + fromEnum IBTickType_High = 6 + fromEnum IBTickType_Low = 7 + fromEnum IBTickType_Volume = 8 + fromEnum IBTickType_Close_Price = 9 + fromEnum IBTickType_Bid_Option_Computation = 10 + fromEnum IBTickType_Ask_Option_Computation = 11 + fromEnum IBTickType_Last_Option_Computation = 12 + fromEnum IBTickType_Model_Option_Computation = 13 + fromEnum IBTickType_Open_Tick = 14 + fromEnum IBTickType_Low_13_Weeks = 15 + fromEnum IBTickType_High_13_Weeks = 16 + fromEnum IBTickType_Low_26_Weeks = 17 + fromEnum IBTickType_High_26_Weeks = 18 + fromEnum IBTickType_Low_52_Weeks = 19 + fromEnum IBTickType_High_52_Weeks = 20 + fromEnum IBTickType_Average_Volume = 21 + fromEnum IBTickType_Open_Interest = 22 + fromEnum IBTickType_Option_Historical_Volatility = 23 + fromEnum IBTickType_Option_Implied_Volatility = 24 + fromEnum IBTickType_Option_Bid_Exchange = 25 + fromEnum IBTickType_Option_Ask_Exchange = 26 + fromEnum IBTickType_Option_Call_Open_Interest = 27 + fromEnum IBTickType_Option_Put_Open_Interest = 28 + fromEnum IBTickType_Option_Call_Volume = 29 + fromEnum IBTickType_Option_Put_Volume = 30 + fromEnum IBTickType_Index_Future_Premium = 31 + fromEnum IBTickType_Bid_Exchange = 32 + fromEnum IBTickType_Ask_Exchange = 33 + fromEnum IBTickType_Auction_Volume = 34 + fromEnum IBTickType_Auction_Price = 35 + fromEnum IBTickType_Auction_Imbalance = 36 + fromEnum IBTickType_Mark_Price = 37 + fromEnum IBTickType_Bid_EFP_Computation = 38 + fromEnum IBTickType_Ask_EFP_Computation = 39 + fromEnum IBTickType_Last_EFP_Computation = 40 + fromEnum IBTickType_Open_EFP_Computation = 41 + fromEnum IBTickType_High_EFP_Computation = 42 + fromEnum IBTickType_Low_EFP_Computation = 43 + fromEnum IBTickType_Close_EFP_Computation = 44 + fromEnum IBTickType_Last_Timestamp = 45 + fromEnum IBTickType_Shortable = 46 + fromEnum IBTickType_RT_Volume = 48 + fromEnum IBTickType_Halted = 49 + fromEnum IBTickType_Bid_Yield = 50 + fromEnum IBTickType_Ask_Yield = 51 + fromEnum IBTickType_Last_Yield = 52 + fromEnum IBTickType_Custom_Option_Computation = 53 + fromEnum IBTickType_Trade_Count = 54 + fromEnum IBTickType_Trade_Rate = 55 + fromEnum IBTickType_Volume_Rate = 56 + fromEnum IBTickType_Last_RTH_Trade = 57 + fromEnum IBTickType_RT_Historical_Volatility = 58 + fromEnum IBTickType_IB_Dividends = 59 + fromEnum IBTickType_Bond_Factor_Multiplier = 60 + fromEnum IBTickType_Regulatory_Imbalance = 61 + fromEnum IBTickType_News = 62 + fromEnum IBTickType_ShortTerm_Volume_3_Minutes = 63 + fromEnum IBTickType_ShortTerm_Volume_5_Minutes = 64 + fromEnum IBTickType_ShortTerm_Volume_10_Minutes = 65 + fromEnum IBTickType_Delayed_Bid = 66 + fromEnum IBTickType_Delayed_Ask = 67 + fromEnum IBTickType_Delayed_Last = 68 + fromEnum IBTickType_Delayed_Bid_Size = 69 + fromEnum IBTickType_Delayed_Ask_Size = 70 + fromEnum IBTickType_Delayed_Last_Size = 71 + fromEnum IBTickType_Delayed_High_Price = 72 + fromEnum IBTickType_Delayed_Low_Price = 73 + fromEnum IBTickType_Delayed_Volume = 74 + fromEnum IBTickType_Delayed_Close = 75 + fromEnum IBTickType_Delayed_Open = 76 + fromEnum IBTickType_RT_Trade_Volume = 77 + fromEnum IBTickType_Creditman_mark_price = 78 + fromEnum IBTickType_Creditman_slow_mark_price = 79 + fromEnum IBTickType_Delayed_Bid_Option = 80 + fromEnum IBTickType_Delayed_Ask_Option = 81 + fromEnum IBTickType_Delayed_Last_Option = 82 + fromEnum IBTickType_Delayed_Model_Option = 83 + fromEnum IBTickType_Last_Exchange = 84 + fromEnum IBTickType_Last_Regulatory_Time = 85 + fromEnum IBTickType_Futures_Open_Interest = 86 + fromEnum IBTickType_Average_Option_Volume = 87 + fromEnum IBTickType_Delayed_Last_Timestamp = 88 + fromEnum IBTickType_Shortable_Shares = 89 + fromEnum IBTickType_ETF_Nav_Close = 92 + fromEnum IBTickType_ETF_Nav_Prior_Close = 93 + fromEnum IBTickType_ETF_Nav_Bid = 94 + fromEnum IBTickType_ETF_Nav_Ask = 95 + fromEnum IBTickType_ETF_Nav_Last = 96 + fromEnum IBTickType_ETF_Nav_Frozen_Last = 97 + fromEnum IBTickType_ETF_Nav_High = 98 + fromEnum IBTickType_ETF_Nav_Low = 99 + +type IB_DerivativeSecType = Text + +data IB_SymbolSample = IB_SymbolSample + { symId :: Int + , symbol :: Text + , secType :: Text + , primaryExchange :: Text + , currency :: Text + , derivatives :: [IB_DerivativeSecType] + } deriving (Show, Eq) + +data IB_IN = IB_PositionData + | IB_ManagedAccts { accounts :: [Text] } + | IB_NextValidID { orderID :: Int } + | IB_ErrorMsg { errorID :: Int, errorCode :: Int, errorMsg :: Text } + | IB_AccountValue { key :: Text, value :: Text, currency :: Text, accountName :: Text } + | IB_AccountUpdateTime { time :: Text } + | IB_PortfolioValue { contract :: IBContract, position :: Float, marketPrice :: Float, marketValue :: Float, averageCost :: Float, unrealizedPNL :: Float, realizedPNL :: Float, accountName :: Text } + | IB_SymbolSamples { nextId :: Int, samples :: [IB_SymbolSample] } + | IB_MarketDataType { tickerId :: Int, dataType :: IBMarketDataType } + | IB_TickReqParams { tickerId :: Int, minTick :: Float, bboExchange :: Text, snapshotPermissions :: Int } + | IB_TickPrice { tickerId :: Int, tickType :: IBTickType, price :: Float, size :: Int, attrMask :: Int } + | IB_TickSize { tickerId :: Int, fieldId :: Int, size :: Int } -- TODO: field is an enum + | IB_TickString { tickerId :: Int, tickType :: IBTickType, content :: Text } + deriving (Show, Eq) + +voidVersion :: LBS.ByteString -> LBS.ByteString -> Get () +voidVersion t v = do + version <- getLazyByteStringNul + when (version /= v) $ D.trace ("Unexpected Version '" <> LBS8.unpack version <> "' for Message-Type " <> LBS8.unpack t <> ". Expected: '" <> LBS8.unpack v <> "'.") (return ()) + +instance Binary IB_IN where + put (IB_ErrorMsg i c m) = put (IBGenericMessage [IBString "4", IBString "2", IBString $ BS8.pack $ show i, IBString $ BS8.pack $ show c, tToIB m]) + put (IB_AccountValue k v c n) = put (IBGenericMessage [IBString "6", IBString "2", tToIB k, tToIB v, tToIB c, tToIB n]) + put (IB_PortfolioValue IBContract{..} p pp v c u r n) = put $ IBGenericMessage [ IBString "7", IBString "8" -- id/version + , iToIB conId, tToIB symbol, tToIB secType, tToIB lastTradeDate, fToIB strike, tToIB right, tToIB multiplier, tToIB primaryExchange, tToIB currency, tToIB localSymbol, tToIB tradingClass -- contract + , fToIB p, fToIB pp, fToIB v, fToIB c, fToIB u, fToIB r, tToIB n + ] + put (IB_AccountUpdateTime t) = put (IBGenericMessage [IBString "8", IBString "1", tToIB t]) + put (IB_NextValidID v) = put (IBGenericMessage [IBString "9", IBString "1", IBString $ BS8.pack $ show v]) + put (IB_ManagedAccts a) = put (IBGenericMessage [IBString "15", IBArray $ encodeUtf8 <$> a]) + put IB_PositionData = put (IBGenericMessage [IBString "61"]) + put IB_SymbolSamples{} = error "not implemented" + put IB_MarketDataType{} = error "not implemented" + put IB_TickReqParams{} = error "not implemented" + put IB_TickPrice{} = error "not implemented" + put IB_TickSize{} = error "not implemented" + put IB_TickString{} = error "not implemented" + --put (IB_SymbolSamples r s) = put (IBGenericMessage [IBString "79", IBString "1", iToIB r, IBArray $ s]) TODO: FIXME + + get = do + msglen <- getWord32be + when (msglen == 0) $ fail "empty message" + ident <- return <$> getLazyByteStringNul + case ident of + Just "1" -> do + voidVersion "1" "6" + IB_TickPrice <$> ib2int <*> (toEnum <$> ib2int) <*> ib2f <*> ib2int <*> ib2int + Just "2" -> do + voidVersion "2" "6" + IB_TickSize <$> ib2int <*> ib2int <*> ib2int + Just "4" -> do + voidVersion "4" "2" + IB_ErrorMsg <$> ib2int <*> ib2int <*> ib2txt + Just "6" -> do + voidVersion "6" "2" + IB_AccountValue <$> ib2txt <*> ib2txt <*> ib2txt <*> ib2txt + Just "7" -> do + voidVersion "7" "8" + c <- IBContract <$> ib2int <*> ib2txt <*> ib2txt <*> ib2txt <*> ib2f <*> ib2txt <*> ib2txt <*> pure "" <*> ib2txt <*> ib2txt <*> ib2txt <*> ib2txt + IB_PortfolioValue (c False "" "" "" [] Nothing) <$> ib2f <*> ib2f <*> ib2f <*> ib2f <*> ib2f <*> ib2f <*> ib2txt + Just "8" -> do + voidVersion "8" "1" + IB_AccountUpdateTime <$> ib2txt + Just "9" -> do + voidVersion "9" "1" + IB_NextValidID <$> ib2int + Just "15" -> do + len <- ib2int + IB_ManagedAccts <$> forM [1..len] (const ib2txt) + Just "46" -> do + voidVersion "46" "6" + IB_TickString <$> ib2int <*> (toEnum <$> ib2int) <*> ib2txt + Just "58" -> do + voidVersion "58" "1" + IB_MarketDataType <$> ib2int <*> (toEnum <$> ib2int) + Just "61" -> return IB_PositionData + Just "79" -> do + reqId <- ib2int + len <- ib2int + symsamples <- forM [1..len] $ const $ do + f <- IB_SymbolSample <$> ib2int <*> ib2txt <*> ib2txt <*> ib2txt <*> ib2txt + n <- ib2int + derivatives <- forM [1..n] $ const ib2txt + return $ f derivatives + return $ IB_SymbolSamples reqId symsamples + Just "81" -> do + IB_TickReqParams <$> ib2int <*> ib2f <*> ib2txt <*> ib2int + Just x -> do + payload <- getByteString (fromIntegral msglen - (if null ident then 0 else length ident + 1) - 1) -- drop rest of message + D.trace ("Payload for "<> LBS8.unpack x <> " not understood: " <> show (IBGenericMessage $ fmap IBString . BS.split 0 . BS.init $ payload)) $ return () + fail $ "unkonwn IB_IN type " <> LBS8.unpack x + Nothing -> fail "Cannot decode Message: no identifier" + +ib2int :: Get Int +ib2int = fromMaybe (-1) . readMaybe . LBS8.unpack <$> getLazyByteStringNul + +ib2f :: Get Float +ib2f = fromMaybe (-1) . readMaybe . LBS8.unpack <$> getLazyByteStringNul + +ib2txt :: Get Text +ib2txt = decodeUtf8 . LBS.toStrict <$> getLazyByteStringNul diff --git a/src/Import.hs b/src/Import.hs new file mode 100644 index 0000000..4eba0e4 --- /dev/null +++ b/src/Import.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Import + ( module RIO + , module Types + , module Data.Aeson + , module Data.Default + , module Text.Show.Pretty + , module IBClient.Types + ) where + +import RIO +import Types +import Data.Aeson (FromJSON, ToJSON) +import Data.Default +import Text.Show.Pretty +import IBClient.Types diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 index 0000000..56e801a --- /dev/null +++ b/src/Run.hs @@ -0,0 +1,230 @@ +{-# 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.OpenGL3 +import DearImGui.GLFW +import Graphics.GL +import Data.StateVar +import qualified Graphics.UI.GLFW as GLFW +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM +import qualified Data.FingerTree as FT + +import IBClient.Connection + +run :: RIO App () +run = do + -- set up IB connection & start threads feeding stuff + + renderLoop + + -- close connections to IB + +renderLoop :: RIO App () +renderLoop = do + win <- appWindow <$> ask + + liftIO GLFW.pollEvents + close <- liftIO $ GLFW.windowShouldClose win + if close + then do + -- save settings & config + (w,h) <- liftIO $ GLFW.getWindowSize win + settings <- appSettings <$> ask + refs <- appRefs <$> ask + host' <- liftIO . readTVarIO . twsConnectionRefsHost . twsConnectionRefs $ refs + port' <- liftIO . readTVarIO . twsConnectionRefsPort . twsConnectionRefs $ refs + let settings' = settings & windowParams . windowWidth .~ w + & windowParams . windowHeight .~ h + & twsConnection . host .~ T.pack host' + & twsConnection . port .~ T.pack port' + liftIO $ encodeFile "settings.json" settings' + logInfo $ display ("Settings Saved" :: Text) + -- save cached data + + logInfo $ display $ T.pack $ ppShow settings' + 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 + glfwNewFrame + newFrame + + + -- Menu bar + withMainMenuBarOpen $ do + withMenuOpen "File" $ do + menuItem "Quit" >>= \case + False -> return () + True -> liftIO $ GLFW.setWindowShouldClose win True + let cr = twsConnectionRefs refs' + accs <- fmap HM.keys $ liftIO $ readTVarIO $ Types.accounts data' + withComboOpen "Account" (maybe "Select account" T.unpack selectedAccount) $ do + forM_ accs $ \a -> do + selectable (T.unpack a) >>= \case + False -> return () + True -> do + -- cancel subscription of old account (if any) + readTVarIO (currentAccount refs') >>= \case + Nothing -> return () + Just aid -> liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData False aid + -- subscribe to new account + liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a + -- finally change + liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just 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 " <> T.pack connHost <> ":" <> T.pack 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 String) + 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 " <> T.pack connHost <> ":" <> T.pack 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 String) + 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 + whenM tableNextColumn (text $ T.unpack $ localSymbol c) + whenM tableNextColumn (text $ show p) + whenM tableNextColumn (text $ show up) + whenM tableNextColumn (text $ show rp) + whenM tableNextColumn (text $ show mp) + whenM tableNextColumn (text $ 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 @String 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 = "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 = whenM tableNextColumn $ text $ T.unpack x + tableNextRow + whenM tableNextColumn $ do + void $ selectableWith (defSelectableOptions { flags = ImGuiSelectableFlags_SpanAllColumns }) (T.unpack _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 (T.unpack symbol)) end $ do + Chart{..} <- liftIO . readTVarIO $ cVar + case viewr chartData of + EmptyR -> text "no last price" + (_ :> ChartPoint{..}) -> text $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay + text $ ppShow chartCache + text $ ppShow lastCacheUpdate + 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 $ GLFW.swapBuffers win + + renderLoop diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..1abe00a --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Types where + +import Data.Aeson hiding (Options) +import Data.Default +import Data.StateVar +import Data.Types.Injective +import Data.Time +import Data.FingerTree +import Data.Semigroup +import GHC.Generics +import Graphics.UI.GLFW (Window) +import DearImGui +import RIO +import RIO.Process +import Lens.Micro.TH +import qualified Data.Text as T + +import IBClient.Types + +-- | Command line arguments +data Options = Options + { optionsVerbose :: !Bool + } + +data WindowParams = WindowParams + { _windowHeight :: Int + , _windowWidth :: Int + } deriving (Show, Generic, FromJSON, ToJSON) + +instance Default WindowParams where + def = WindowParams 1024 768 + +data TWSConnection = TWSConnection + { _host :: Text + , _port :: Text + } deriving (Show, Generic, FromJSON, ToJSON) + +instance Default TWSConnection where + def = TWSConnection "127.0.0.1" "7497" + +instance FromJSON LogLevel where + parseJSON = withText "LogLevel" $ \case + "LevelDebug" -> return LevelDebug + "LevelInfo" -> return LevelInfo + "LevelWarn" -> return LevelWarn + "LevelError" -> return LevelError + x -> fail $ T.unpack $ "encountered "<>x + +instance ToJSON LogLevel where + toJSON LevelDebug = String "LevelDebug" + toJSON LevelInfo = String "LevelInfo" + toJSON LevelWarn = String "LevelWarn" + toJSON LevelError = String "LevelError" + toJSON (LevelOther _) = String "LevelDebug" + +data Settings = Settings + { _windowParams :: WindowParams + , _twsConnection :: TWSConnection + , _logLevel :: LogLevel + } deriving (Show, Generic, FromJSON, ToJSON) + +makeLenses ''WindowParams +makeLenses ''TWSConnection +makeLenses ''Settings + +instance Default Settings where + def = Settings def def LevelWarn + +data TWSConnectionStatus = TWSDisconnected + | TWSConnecting + | TWSConnected + deriving (Show, Eq, Enum, Bounded) + +data TWSConnectionRefs = TWSConnectionRefs + { twsConnectionRefsHost :: TVar String + , twsConnectionRefsPort :: TVar String + , twsConnectionStatus :: TVar TWSConnectionStatus + , twsConnectionSend :: TQueue Msg_IB_OUT + , twsConnectionRecieve :: TQueue Msg_IB_IN + } + +instance Injective TWSConnectionStatus ImVec4 where + to = \case + TWSDisconnected -> ImVec4 1 0 0 1 + TWSConnecting -> ImVec4 1 1 0 1 + TWSConnected -> ImVec4 0 1 0 1 + +instance Injective TWSConnectionStatus String where + to = \case + TWSDisconnected -> "Not Connected" + TWSConnecting -> "Trying to connect..." + TWSConnected -> "Connected" + +data DataRefs = DataRefs + { accounts :: TVar (HashMap Text IBAccount) + , nextValidID :: TVar (Maybe Int) + , nextSymbolLookup :: TVar Text + , symbolLookupResults :: TVar [IBSymbolSample] + } +mkIBAccount :: Text -> IBAccount +mkIBAccount u = IBAccount (IBAccountInfo u mempty mempty) mempty mempty + +data IBAccount = IBAccount + { _accountInfo :: IBAccountInfo + , _accountPortfolio :: [IBPortfolioValue] + , _accountStrategies :: [IBAccountStrategy] + } deriving (Show, Eq) + + +data IBAccountInfo = IBAccountInfo + { _accountName :: Text + , _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency) + , _accountLastUpdate :: Text + } deriving (Show, Eq) + +data IBPortfolioValue = IBPortfolioValue + { _contract :: IBContract + , _position :: Float + , _marketPrice :: Float + , _marketValue :: Float + , _averageCost :: Float + , _unrealizedPNL :: Float + , _realizedPNL :: Float + } deriving (Show, Eq) + +newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy + deriving (Show, Eq) + +data IBSymbolSample = IBSymbolSample + { _symbolId :: Int + , _symbol :: Text + , _secType :: Text + , _primaryExchange :: Text + , _currency :: Text + , _derivatives :: [Text] + } deriving (Show, Eq) + +makeLenses ''IBAccountStrategy +makeLenses ''IBAccountInfo +makeLenses ''IBAccount + +data ChartSettings = ChartSettings + { chartResolution :: Int + , chartStart :: Maybe UTCTime + , chartEnd :: Maybe UTCTime + } deriving (Show, Eq) + +defChartSettings :: ChartSettings +defChartSettings = ChartSettings 60 Nothing Nothing + +-- data TimeWindow = TimeWindow +-- { begin :: Int +-- , end :: Int +-- } deriving (Show, Eq) +-- +-- instance Semigroup TimeWindow where +-- (TimeWindow a b) <> (TimeWindow x y) = TimeWindow (min a x) (max b y) +-- +-- instance Monoid TimeWindow where +-- mempty = TimeWindow 0 86400 + +newtype TimePoint = TimePoint Int + deriving Eq + deriving newtype Show + deriving (Semigroup, Monoid) via (Max Int) + +data ChartStudies = SMA { window :: Int, value :: Float } + | OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float} + deriving (Show, Eq) + +data ChartPoint = ChartPoint + { timeOfDay :: TimePoint + , pointValue :: Float + , pointExtra :: [ChartStudies] + } deriving (Show, Eq) + +instance Measured TimePoint ChartPoint where + measure = timeOfDay + +data Chart = Chart + { chartData :: FingerTree TimePoint ChartPoint + , chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) + , fillerThread :: ThreadId + , chartSettings :: ChartSettings + , chartCache :: [ChartPoint] + , lastCacheUpdate :: Maybe TimePoint + , chartDirty :: Bool + } deriving (Show, Eq) + +newtype InjetiveGettable a b = InjetiveGettable + { gettable :: TVar a + } + +instance (Injective a b) => HasGetter (InjetiveGettable a b) b where + get r = liftIO $ do + (value :: a) <- get (gettable r) + return $ Data.Types.Injective.to value + +instance (Injective b a) => HasSetter (InjetiveGettable a b) b where + t $= a = liftIO $ do + let b = Data.Types.Injective.to a + gettable t $= b + +newtype DefaultJSON a = DefaultJSON { unDefaultJSON :: a } + +instance (FromJSON a, Default a) => FromJSON (DefaultJSON a) where + parseJSON v = DefaultJSON <$> (parseJSON v <|> pure def) + +data AppRefs = AppRefs + { twsConnectionRefs :: TWSConnectionRefs + , currentAccount :: TVar (Maybe Text) + , appCharts :: TVar (HashMap Text (TVar Chart)) + , tickerIdToSymbol :: TVar (HashMap Int Text) + } + +data App = App + { appSettings :: !Settings + , appLogFunc :: !LogFunc + , appProcessContext :: !ProcessContext + , appOptions :: !Options + , appWindow :: !Window + , appRefs :: !AppRefs + , appData :: !DataRefs + -- Add other app-specific configuration information here + } + +instance HasLogFunc App where + logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y }) +instance HasProcessContext App where + processContextL = lens appProcessContext (\x y -> x { appProcessContext = y }) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 index 0000000..b950daa --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | Silly utility module, used to demonstrate how to write a test +-- case. +module Util + ( plus2 + ) where + +import RIO + +plus2 :: Int -> Int +plus2 = (+ 2) diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..fedace7 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,79 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-18.24 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +- deps/dear-imgui.hs +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +extra-deps: + - type-iso-1.0.1.0@sha256:75682a06a5af1798c6641ba3cc175685a1f699962ad22ab194a487c0d6b7da66,1892 + - numericpeano-0.2.0.0@sha256:e3a1dc960817a81f39d276e7bfa0124e8efa1b91b5c272a70dfa16c38627f172,1406 + +allow-newer: true + +# Override default flag values for local packages and extra-deps +flags: + dear-imgui: + # libraries + glfw: true + sdl: false + vulkan: false + # hardware-requirements + opengl3: true + opengl2: false + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 index 0000000..d5bc4df --- /dev/null +++ b/test/UtilSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module UtilSpec (spec) where + +import Import +import Util +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = do + describe "plus2" $ do + it "basic check" $ plus2 0 `shouldBe` 2 + it "overflow" $ plus2 maxBound `shouldBe` minBound + 1 + prop "minus 2" $ \i -> plus2 i - 2 `shouldBe` i