Init
This commit is contained in:
Stefan Dresselhaus
8
.gitignore
vendored
Normal file
8
.gitignore
vendored
Normal file
@@ -0,0 +1,8 @@
|
|||||||
|
*~
|
||||||
|
*.swp
|
||||||
|
tarballs/
|
||||||
|
.stack-work/
|
||||||
|
imgui.ini
|
||||||
|
settings.json
|
||||||
|
*.lock
|
||||||
|
tags
|
||||||
6
.gitmodules
vendored
Normal file
6
.gitmodules
vendored
Normal file
@@ -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
|
||||||
0
.hlint.yaml
Normal file
0
.hlint.yaml
Normal file
3
ChangeLog.md
Normal file
3
ChangeLog.md
Normal file
@@ -0,0 +1,3 @@
|
|||||||
|
# Changelog for ibhelper
|
||||||
|
|
||||||
|
## Unreleased changes
|
||||||
30
LICENSE
Normal file
30
LICENSE
Normal file
@@ -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.
|
||||||
10
README.md
Normal file
10
README.md
Normal file
@@ -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`
|
||||||
108
app/Main.hs
Normal file
108
app/Main.hs
Normal file
@@ -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
|
||||||
|
|
||||||
1
deps/dear-imgui.hs
vendored
Submodule
1
deps/dear-imgui.hs
vendored
Submodule
Submodule deps/dear-imgui.hs added at e5969f6b35
1
deps/dear-implot.hs
vendored
Submodule
1
deps/dear-implot.hs
vendored
Submodule
Submodule deps/dear-implot.hs added at 78f7df091c
248
ibhelper.cabal
Normal file
248
ibhelper.cabal
Normal file
@@ -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
|
||||||
121
package.yaml
Normal file
121
package.yaml
Normal file
@@ -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
|
||||||
79
src/AppFiller.hs
Normal file
79
src/AppFiller.hs
Normal file
@@ -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"
|
||||||
|
|
||||||
|
|
||||||
89
src/Chart.hs
Normal file
89
src/Chart.hs
Normal file
@@ -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
|
||||||
95
src/IBClient/Connection.hs
Normal file
95
src/IBClient/Connection.hs
Normal file
@@ -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"
|
||||||
581
src/IBClient/Types.hs
Normal file
581
src/IBClient/Types.hs
Normal file
@@ -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
|
||||||
16
src/Import.hs
Normal file
16
src/Import.hs
Normal file
@@ -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
|
||||||
230
src/Run.hs
Normal file
230
src/Run.hs
Normal file
@@ -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
|
||||||
240
src/Types.hs
Normal file
240
src/Types.hs
Normal file
@@ -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 })
|
||||||
11
src/Util.hs
Normal file
11
src/Util.hs
Normal file
@@ -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)
|
||||||
79
stack.yaml
Normal file
79
stack.yaml
Normal file
@@ -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
|
||||||
1
test/Spec.hs
Normal file
1
test/Spec.hs
Normal file
@@ -0,0 +1 @@
|
|||||||
|
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||||
14
test/UtilSpec.hs
Normal file
14
test/UtilSpec.hs
Normal file
@@ -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
|
||||||
Reference in New Issue
Block a user