commit befb1ab1eb9a5af10478226ec6e03dd0442de80e Author: Stefan Dresselhaus Date: Mon Mar 14 20:12:24 2022 +0100 Init 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