Drezil/ibhelper
1
1
Fork 0
Code Issues 12 Pull Requests Projects Releases Wiki Activity

Compare commits

base: Drezil:42183873d8b1c58575006ca41888fb0af66eac91
Branches Tags
Drezil:main
..
compare: Drezil:fcf8c261377ce4d5294016fbeab2cd38c9f657ad
Branches Tags
Drezil:main

No commits in common. "42183873d8b1c58575006ca41888fb0af66eac91" and "fcf8c261377ce4d5294016fbeab2cd38c9f657ad" have entirely different histories.
42183873d8 ... fcf8c26137

8 changed files with 112 additions and 309 deletions
Show Stats Expand all files Collapse all files

2
deps/dear-implot.hs vendored

@ -1 +1 @@
Subproject commit 2b3810f7927a83c7cf95612497eaeceed56ca5e8 Subproject commit f3d5b63b541d8048568f134403838213c77177e4

14
ibhelper.cabal
View File

@ -78,18 +78,7 @@ library
TypeSynonymInstances TypeSynonymInstances
ViewPatterns ViewPatterns
DuplicateRecordFields DuplicateRecordFields
ghc-options: ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -static -dynamic-too
-Wall
-Wcompat
-Widentities
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wpartial-fields
-Wredundant-constraints
-Wderiving-defaults
-Wmissing-deriving-strategies
-static
-dynamic-too
-- include-dirs: -- include-dirs:
-- deps/dear-implot.hs/implot -- deps/dear-implot.hs/implot
-- deps/dear-imgui.hs/imgui -- deps/dear-imgui.hs/imgui
@ -120,7 +109,6 @@ library
, time , time
, type-iso , type-iso
, unordered-containers , unordered-containers
, vector
default-language: Haskell2010 default-language: Haskell2010
executable ibhelper-exe executable ibhelper-exe

8
src/AppFiller.hs
View File

@ -37,11 +37,11 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
$ unless (L.null as) $ unless (L.null as)
$ switchAccountTo $ L.head as $ switchAccountTo $ L.head as
(Msg_IB_IN (IB_NextValidID i)) -> atomically $ modifyTVar' (nextValidID currentAppData) (const (Just i)) (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_ErrorMsg i c m)) -> debugMsg "IB_ErrorMsg not implemented"
(Msg_IB_IN (IB_AccountValue k v c n)) -> do (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 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 atomically $ modifyTVar' (Types.accounts currentAppData) action
(Msg_IB_IN (IB_AccountUpdateTime _t)) -> debugMsg "IB_AccountUpdateTime not implemented" (Msg_IB_IN (IB_AccountUpdateTime t)) -> debugMsg "IB_AccountUpdateTime not implemented"
-- (Msg_IB_IN (IB_AccountUpdateTime t)) -> do -- (Msg_IB_IN (IB_AccountUpdateTime t)) -> do
-- let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n -- let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n
-- atomically $ modifyTVar' (Types.accounts currentAppData) action -- atomically $ modifyTVar' (Types.accounts currentAppData) action
@ -72,8 +72,8 @@ handleTickPrice IB_TickPrice{..} = do
chartVar <- (HM.!s) <$> liftIO (readTVarIO charts) chartVar <- (HM.!s) <$> liftIO (readTVarIO charts)
case tickType of case tickType of
IBTickType_Last_Price -> do IBTickType_Last_Price -> do
t <- utcTimeToSeconds <$> liftIO getCurrentTime t <- utctDayTime <$> liftIO getCurrentTime
let cp = ChartPoint (TimePoint t) price (fromIntegral size) [] let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price size []
liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True}) liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True})
_ -> return () _ -> return ()
handleTickPrice _ = error "impossible" handleTickPrice _ = error "impossible"

233
src/Chart.hs
View File

@ -3,39 +3,32 @@
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
module Chart (newChart module Chart (newChart, FillerException(..), getUpdatedChartCache) where
, FillerException(..)
, getUpdatedChartCache
, getChunkedDay
, timePointToIndex
, indexToTimePoint
) where
import Import import Import
import Control.Concurrent (forkIO)
import Control.Monad.Extra (ifM)
import Data.Aeson (eitherDecodeFileStrict') import Data.Aeson (eitherDecodeFileStrict')
import Data.FingerTree (FingerTree)
import Data.Time.Calendar (Day(..))
import Data.Time.Clock
import Data.Maybe (fromJust)
import RIO.FilePath
import RIO.List import RIO.List
import RIO.List.Partial import RIO.List.Partial
import RIO.FilePath
import qualified Data.FingerTree as FT import Data.Time.Calendar (Day(..))
import Data.FingerTree (FingerTree)
import Control.Concurrent (forkIO)
import Control.Monad.Extra (ifM)
import qualified RIO.ByteString as BS
-- import Control.Exception
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.List as L import qualified Data.FingerTree as FT
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector.Storable as VS
--import qualified Debug.Trace as D import qualified Debug.Trace as D
data FillerException = QuitFiller data FillerException = QuitFiller
deriving stock Show deriving Show
instance Exception FillerException instance Exception FillerException
--deriving via Integer instance Hashable Day
newChart :: IBContract -> RIO App () newChart :: IBContract -> RIO App ()
newChart contract = do newChart contract = do
app <- ask app <- ask
@ -46,29 +39,19 @@ newChart contract = do
unless (sym `HM.member` hm) $ do unless (sym `HM.member` hm) $ do
today <- liftIO getCurrentDay :: RIO App Day today <- liftIO getCurrentDay :: RIO App Day
(cacheErrors, cacheData) <- do (cacheErrors, cacheData) <- do
ifM (fmap not $ liftIO $ doesDirectoryExist $ "cache" </> show con) files <- liftIO $ listDirectory $ "cache" </> show con
(return $ (["no data-chache found for " <> show con], [])) $ do res <- forM files $ \cacheFileName -> do
files <- liftIO $ listDirectory $ "cache" </> show con let fname = "cache" </> show con </> cacheFileName
res <- forM files $ \cacheFileName -> do ifM (liftIO $ doesFileExist fname)
let fname = "cache" </> show con </> cacheFileName (bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname))
ifM (liftIO $ doesFileExist fname) (return $ Left $ "cachefile "<>cacheFileName<>" not found.")
(bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname)) return $ partitionEithers res
(return $ Left $ "cachefile "<>cacheFileName<>" not found.")
return $ partitionEithers res
unless (null cacheErrors) $ forM_ cacheErrors $ \err -> logError (displayShow err) unless (null cacheErrors) $ forM_ cacheErrors $ \err -> logError (displayShow err)
let (unknownDates, cacheData') = partition (isNothing . fst) cacheData let (unknownDates, cacheData') = partition (isNothing . fst) cacheData
unless (null unknownDates) $ logError $ display $ T.pack $ show (length unknownDates) <> " files had no parsable Date." unless (null unknownDates) $ logError $ display $ T.pack $ show (length unknownDates) <> " files had no parsable Date."
let cacheData'' :: HashMap Day (FingerTree TimePoint ChartPoint) = HM.fromList $ bimap (fromMaybe today) FT.fromList <$> cacheData' let cacheData'' :: HashMap Day (FingerTree TimePoint ChartPoint) = HM.fromList $ bimap (fromMaybe today) FT.fromList <$> cacheData'
logError $ displayShow $ HM.keys cacheData'' logError $ displayShow $ HM.keys cacheData''
c <- liftIO $ newTVarIO $ Chart con c <- liftIO $ newTVarIO $ Chart con (fromMaybe FT.empty $ cacheData'' HM.!? today) (HM.delete today cacheData'') undefined defChartSettings [] Nothing False
(fromMaybe FT.empty $ cacheData'' HM.!? today)
(HM.delete today cacheData'')
undefined
defChartSettings
defChartCacheSettings
(emptyChartCacheData defChartCacheSettings)
Nothing
False
tid <- liftIO $ forkIO $ fillChart app contract c tid <- liftIO $ forkIO $ fillChart app contract c
liftIO $ atomically $ do liftIO $ atomically $ do
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..}) modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
@ -84,7 +67,7 @@ fillChart app contract cVar = runRIO app $ do
let cancelSubscription = liftIO $ atomically $ do let cancelSubscription = liftIO $ atomically $ do
modifyTVar tickerMapVar (HM.delete tickerId) modifyTVar tickerMapVar (HM.delete tickerId)
-- TODO: send cancel-request -- TODO: send cancel-request
let sendQ = twsConnectionSend . twsConnectionRefs . appRefs $ app let sendQ = twsConnectionSend $ twsConnectionRefs $ appRefs $ app
liftIO $ atomically $ do liftIO $ atomically $ do
modifyTVar tickerMapVar (HM.insert tickerId sym) modifyTVar tickerMapVar (HM.insert tickerId sym)
writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False
@ -93,154 +76,40 @@ fillChart app contract cVar = runRIO app $ do
-- chart dirty? set clean & begin work -- chart dirty? set clean & begin work
c <- liftIO (readTVarIO cVar) c <- liftIO (readTVarIO cVar)
when (chartDirty c) $ do when (chartDirty c) $ do
liftIO $ atomically $ modifyTVar cVar (\c' -> c' { chartDirty = False }) liftIO $ atomically $ modifyTVar cVar (\c -> c { chartDirty = False })
(lUpdate, cachePoints) <- getUpdatedChartCache c Nothing let (lUpdate, cachePoints) = getUpdatedChartCache c Nothing
liftIO $ atomically $ modifyTVar cVar (\c' -> c' { chartCache = cachePoints, lastCacheUpdate = lUpdate }) liftIO $ atomically $ modifyTVar cVar (\c -> c { chartCache = cachePoints, lastCacheUpdate = lUpdate })
return () return ()
threadDelay 1000000 -- sleep 5 seconds threadDelay 1000000 -- sleep 5 seconds
chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])] getUpdatedChartCache :: Chart -> Maybe ChartSettings -> (Maybe TimePoint, [ChartPoint])
chunkChart from until range tree = go from range interval getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart)
where where (TimePoint cacheUpdateStart) = fromMaybe (TimePoint 0) Nothing -- TODO: lastCacheUpdate
lastItem = case FT.viewr interval of cacheUpdateEnd = 86400
FT.EmptyR -> until chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])]
(_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay chunkChart from until range tree = go from range interval
interval = FT.takeUntil (\(TimePoint x) -> x > until) where
. FT.dropUntil (\(TimePoint x) -> x > from) lastItem = case FT.viewr interval of
$ tree FT.EmptyR -> until
go f i t (_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay
| f+i >= lastItem = [(TimePoint (f+i), toList t)] interval = FT.takeUntil (\(TimePoint x) -> x > until)
| otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t . FT.dropUntil (\(TimePoint x) -> x > from)
in (TimePoint (f+i),toList a) : go (f+i) i b $ tree
go f i t
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint | f+i >= lastItem = [(TimePoint (f+i), toList t)]
toCachePoint (t,[]) = ChartPoint t (-1) 0 [] | otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c] in (TimePoint (f+i),toList a) : go (f+i) i b
where chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution $ fromMaybe chartSettings chartSettings') chartData
vol = sum $ pointVolume <$> as lUpdate = fmap fst . lastMaybe $ chunkedChart
as' = pointValue <$> as toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
ms' = sum $ (\x -> pointValue x * pointVolume x) <$> as toCachePoint (t,[]) = ChartPoint t (-1) 0 []
m = ms' / vol toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
o = head as'
c = last as'
l = minimum as'
h = maximum as'
getUpdatedChartCache :: Chart -> Maybe ChartCacheSettings -> RIO App (Maybe TimePoint, ChartCacheData)
getUpdatedChartCache Chart{..} chartCacheSettings' = do
let ChartCacheSettings cRes cTicks = fromMaybe chartCacheSettings chartCacheSettings'
now <- liftIO getCurrentTime
-- - recalculate cacheUpdateStart & cacheUpdateEnd
let cacheUpdateEnd = ((utcTimeToSeconds now + cRes) `div` cRes) * cRes
cacheUpdateStart = cacheUpdateEnd - (cRes * cTicks)
ChartCacheData ccData ccAxis ccRange ccFill = chartCache
chunks = case ccFill of
Nothing -> [(cacheUpdateStart, cacheUpdateEnd)]
Just (mi, ma) -> if
-- Interval mi-ma already updated. get remaining intervals
-- mi ma cUS cUE
| ma < cacheUpdateStart -> [(cacheUpdateStart, cacheUpdateEnd)]
-- mi? cUS mi? ma cUE -> [ma,cUE] + rest
| ma < cacheUpdateEnd -> [(ma,cacheUpdateEnd)] <> if
-- cUS mi ma
| mi > cacheUpdateStart -> [(cacheUpdateStart, mi)]
| otherwise -> []
| otherwise -> []
-- - chunk them with chunhChart
chunkedChart = L.filter (not . null . snd) $ L.concat $ for chunks $ \(start, end) -> chunkChart (min 0 start) end cRes chartData
lUpdate = cacheUpdateEnd - cRes
-- - calculate Range and need for shift
shiftNeccessary = case ccRange of
Nothing -> False
Just (_,ma) -> cacheUpdateEnd > ma
(newRange, shiftInterval) = if not shiftNeccessary && isJust ccRange then (fromJust ccRange, 0) else
let interval = cTicks `div` 20 :: Int
iTo = ((cacheUpdateEnd + cRes * interval) `div` (cRes * interval)) * (cRes * interval)
iFrom = iTo - 20 * (cRes * interval)
in ((iFrom,iTo), interval)
ccAxis' = if not shiftNeccessary && isJust ccRange then ccAxis
else VS.enumFromStepN (fromIntegral $ fst newRange) (fromIntegral cRes) cTicks
logDebug $ displayShow ("now, updateEnd, lUpdate" :: Text, utcTimeToSeconds now, cacheUpdateEnd, lUpdate)
-- create data for updates
let timePointToIndex' :: TimePoint -> Int
timePointToIndex' = timePointToIndex (Just $ ChartCacheSettings cRes cTicks) newRange
let indexToTimePoint' :: Int -> TimePoint
indexToTimePoint' = indexToTimePoint (Just $ ChartCacheSettings cRes cTicks) newRange
-- fold instead of map, so we can carry over cached calculatinos from element to element (for i.e. ema/sma)
let (!foldedData,_,_) = foldl' folder ([], ChartPoint 0 0 0 [], mempty) chunkedChart
folder :: ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float]) -> (TimePoint, [ChartPoint]) -> ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float])
folder old (_,[]) = old
folder (acc, lastPoint, smaMap) (tp,cdata) = ((timePointToIndex' tp, cp):acc, cp, foldl' (.) id smaUpdates smaMap)
where where
cp = ChartPoint tp m vol studies vol = sum $ volume <$> as
(studies, smaUpdates) = unzip $ catMaybes $ (chartStudySettings chartSettings :: [ChartStudyType]) <&> \case as' = pointValue <$> as
ChartStudyTypeOpen -> Just (OLHC o l h c, id) ms' = sum $ (\x -> pointValue x * fromIntegral (volume x)) <$> as
ChartStudyTypeHigh -> Nothing m = ms' / fromIntegral vol
ChartStudyTypeLow -> Nothing
ChartStudyTypeClose -> Nothing
ChartStudyTypeDirect -> Nothing
ChartStudyTypeSMA w -> Nothing --TODO: fixme #13, do the calculation & use data inside smaMap and return (SMA x y, smaUpdate)
ChartStudyTypeVolume -> Just (Volume vol, id)
vol = sum $ pointVolume <$> cdata
as' = pointValue <$> cdata
ms' = sum $ (\x -> pointValue x * pointVolume x) <$> cdata
m = ms' / vol
o = head as' o = head as'
c = last as' c = last as'
l = minimum as' l = minimum as'
h = maximum as' h = maximum as'
-- plan the actual work
updates = chartStudySettings chartSettings <&> \cs ->
-- check if thing is in hashmap
let vec = case ccData HM.!? cs of
Nothing -> VS.replicate cTicks 0
Just a -> a
-- shift if neccessary
vec' = if shiftNeccessary && cs `HM.member` ccData then
-- TODO: unsafeSlice && unsafeUpdate_ - see #16
let sliceLength = VS.length vec - shiftInterval
in VS.update_ vec (VS.enumFromN 0 sliceLength) (VS.slice shiftInterval sliceLength vec)
else
vec
-- NOW:
-- newRange is (rangeFrom, rangeTo) in seconds with 0 being last midnight
-- vec' has that range mapped to indices [0,cTicks-1] with every cRes being one time-slice
-- everything in the chunkedChart-list has to be inserted if in range using the same time-notation like the range
-- (hint: chunkedChart is (time, [data]), with time being the point at the end of each contained interval)
findOLHC as = fromJust $ find (\case OLHC{} -> True; _ -> False) as
findVolume as = fromJust $ find (\case Volume{} -> True; _ -> False) as
in case cs of
ChartStudyTypeDirect -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ x _ _) -> (i,x)) <$> foldedData))
ChartStudyTypeOpen -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_open $ findOLHC s)) <$> foldedData))
ChartStudyTypeLow -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_low $ findOLHC s)) <$> foldedData))
ChartStudyTypeHigh -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_high $ findOLHC s)) <$> foldedData))
ChartStudyTypeClose -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_close $ findOLHC s)) <$> foldedData))
ChartStudyTypeSMA x -> id --TODO: implement #13
ChartStudyTypeVolume -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,volume $ findVolume s)) <$> foldedData))
let ccData' = foldl' (.) id updates ccData
-- logInfo $ displayShow chartCache
-- logInfo $ displayShow (cacheUpdateStart, cacheUpdateEnd)
-- logInfo $ displayShow (newRange, chunkedChart)
let ma = timePointToIndex' $ TimePoint lUpdate
mi = fromMaybe ma $ fst <$> ccFill
return (Just $ TimePoint lUpdate, ChartCacheData ccData' ccAxis' (Just newRange) (Just $ (mi, timePointToIndex' $ TimePoint lUpdate)))
getChunkedDay :: Chart -> Maybe Int -> (Maybe TimePoint, [ChartPoint])
getChunkedDay Chart{..} chunkResolution = (lUpdate, toCachePoint <$> chunkedData)
where
chunkedData = chunkChart 0 86400 (fromMaybe (chartCacheResolution chartCacheSettings) chunkResolution) chartData
lUpdate = fmap fst . lastMaybe $ chunkedData
indexToTimePoint :: Maybe ChartCacheSettings -> (Int, Int) -> Int -> TimePoint
indexToTimePoint ccs (rFrom, rTo) i = TimePoint $ rFrom + i*cRes
where
ChartCacheSettings cRes _ = fromMaybe defChartCacheSettings ccs
timePointToIndex :: Maybe ChartCacheSettings -> (Int, Int) -> TimePoint -> Int
timePointToIndex ccs (rFrom, rTo) (TimePoint p) = if
| p < rFrom || p > rTo -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show p <> " out of range."
| result < 0 || result >= cTicks -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show result <> " is invalid index"
| otherwise -> result
where
ChartCacheSettings cRes cTicks = fromMaybe defChartCacheSettings ccs
result = (p - rFrom) `div` cRes

3
src/IBClient/Types.hs
View File

@ -44,8 +44,7 @@ toBS (IBBool False) = "0"--BS.pack [0,0,0,0] -- bool == 32-bit int in IB
newtype IBGenericMessage = IBGenericMessage newtype IBGenericMessage = IBGenericMessage
{ fields :: [IBTypes] { fields :: [IBTypes]
} deriving stock (Show) } deriving (Show, Eq)
deriving newtype (Eq)
instance Binary IBGenericMessage where instance Binary IBGenericMessage where
put (IBGenericMessage f) = do put (IBGenericMessage f) = do

4
src/Import.hs
View File

@ -10,7 +10,6 @@ module Import
, ppShow' , ppShow'
, getCurrentDay , getCurrentDay
, switchAccountTo , switchAccountTo
, utcTimeToSeconds
) where ) where
import RIO import RIO
@ -45,6 +44,3 @@ switchAccountTo a = do
liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a
-- finally change -- finally change
liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a) liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a)
utcTimeToSeconds :: UTCTime -> Int
utcTimeToSeconds = fromInteger . (`div` ((10 :: Integer)^(12 :: Integer))) . diffTimeToPicoseconds . utctDayTime

37
src/Run.hs
View File

@ -4,26 +4,27 @@
module Run (run) where module Run (run) where
import Import import Import
import Types
import Chart import Chart
import Types
import Control.Concurrent import Control.Concurrent
import Data.Aeson (encodeFile) import Data.Aeson (encodeFile)
import Data.Bits import Data.Bits
import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree) import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree)
import Data.Maybe (fromJust)
import Data.Time.Clock
import Data.Tuple.Extra
import DearImGui import DearImGui
import DearImGui.OpenGL3
import DearImGui.Plot import DearImGui.Plot
import DearImGui.OpenGL3
import DearImGui.SDL import DearImGui.SDL
import Data.Time.Clock
import Graphics.GL import Graphics.GL
import SDL import SDL
--import Data.StateVar
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.List as L
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.Vector.Storable as VS --import qualified Data.FingerTree as FT
import IBClient.Connection import IBClient.Connection
import Import (Chart(chartContractID))
run :: RIO App () run :: RIO App ()
run = do run = do
@ -51,13 +52,13 @@ shutdownApp = do
-- save cached data -- save cached data
liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache" liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache"
charts <- liftIO . readTVarIO . appCharts $ refs charts <- liftIO . readTVarIO . appCharts $ refs
forM_ (HM.toList charts) $ \(_symbol,tc) -> do forM_ (HM.toList charts) $ \(symbol,tc) -> do
c@Chart{..} <- liftIO . readTVarIO $ tc c@Chart{..} <- liftIO . readTVarIO $ tc
today <- liftIO $ utctDay <$> getCurrentTime today <- liftIO $ utctDay <$> getCurrentTime
liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID
let (_, chartData') = getChunkedDay c (Just 5) let (_, chartData') = getUpdatedChartCache c (Just $ ChartSettings 5 Nothing Nothing)
newData = HM.toList newData = HM.toList
. fmap (filter (\ChartPoint{..} -> 0 /= pointVolume)) . fmap (filter (\ChartPoint{..} -> 0 /= volume))
. HM.alter (Just . maybe chartData' (<>chartData')) today . HM.alter (Just . maybe chartData' (<>chartData')) today
. fmap toList . fmap toList
$ chartHistData $ chartHistData
@ -164,7 +165,7 @@ renderLoop = do
tableSetupColumn "AVG" tableSetupColumn "AVG"
tableSetupColumn "Market Value" tableSetupColumn "Market Value"
tableHeadersRow tableHeadersRow
forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv _ac up rp) -> forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv ac up rp) ->
do do
tableNextRow tableNextRow
tableNextColumn $ text $ localSymbol c tableNextColumn $ text $ localSymbol c
@ -202,7 +203,7 @@ renderLoop = do
when mustSort $ liftIO $ pPrint sortSpecs when mustSort $ liftIO $ pPrint sortSpecs
tableHeadersRow tableHeadersRow
lResult <- readTVarIO $ symbolLookupResults data' lResult <- readTVarIO $ symbolLookupResults data'
forM_ lResult $ \IBSymbolSample{..} -> do forM_ lResult $ \contract@IBSymbolSample{..} -> do
let popupName = fromString $ "SymbolAction"<>show _symbolId let popupName = fromString $ "SymbolAction"<>show _symbolId
withPopup popupName $ \isPopupOpen -> do withPopup popupName $ \isPopupOpen -> do
when isPopupOpen $ do when isPopupOpen $ do
@ -231,17 +232,9 @@ renderLoop = do
(_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay (_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay
withPlot "Test" $ do withPlot "Test" $ do
-- TODO: set axes -- TODO: set axes
-- let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
setupAxisLimits (both fromIntegral $ fromMaybe (0,86400) $ chartCacheCurrent chartCache) (-100,2500) Nothing plotLine (T.unpack symbol) x y
let ChartCacheSettings _ cTicks = chartCacheSettings return ()
(f, t) = fromMaybe (0, cTicks) $ chartCacheFilledTo chartCache
direct = chartCacheData chartCache HM.!? ChartStudyTypeDirect
x = chartCacheAxis chartCache
-- t-f == 0 means there is still 1 point in it. VS.slice takes number of points as second argument. Add 1!
-- dataSlice = VS.slice f (t-f+1)
dataSliceLine = if t-f < 1 then VS.slice (max 0 $ f-1) 2 else VS.slice f (t-f+1) -- need at least 2 points to make a line... duh!
when (isJust direct) $ do
plotLine (T.unpack symbol) (dataSliceLine x) (dataSliceLine $ fromJust direct)
return () return ()

120
src/Types.hs
View File

@ -24,7 +24,6 @@ import RIO
import RIO.Process import RIO.Process
import Lens.Micro.TH import Lens.Micro.TH
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector.Storable as VS
import IBClient.Types import IBClient.Types
@ -36,8 +35,7 @@ data Options = Options
data WindowParams = WindowParams data WindowParams = WindowParams
{ _windowWidth :: Int { _windowWidth :: Int
, _windowHeight :: Int , _windowHeight :: Int
} deriving stock (Show, Generic) } deriving (Show, Generic, FromJSON, ToJSON)
deriving anyclass (FromJSON, ToJSON)
instance Default WindowParams where instance Default WindowParams where
def = WindowParams 1024 768 def = WindowParams 1024 768
@ -45,8 +43,7 @@ instance Default WindowParams where
data TWSConnection = TWSConnection data TWSConnection = TWSConnection
{ _host :: Text { _host :: Text
, _port :: Text , _port :: Text
} deriving stock (Show, Generic) } deriving (Show, Generic, FromJSON, ToJSON)
deriving anyclass (FromJSON, ToJSON)
instance Default TWSConnection where instance Default TWSConnection where
def = TWSConnection "127.0.0.1" "7497" def = TWSConnection "127.0.0.1" "7497"
@ -70,8 +67,7 @@ data Settings = Settings
{ _windowParams :: WindowParams { _windowParams :: WindowParams
, _twsConnection :: TWSConnection , _twsConnection :: TWSConnection
, _logLevel :: LogLevel , _logLevel :: LogLevel
} deriving stock (Show, Generic) } deriving (Show, Generic, FromJSON, ToJSON)
deriving anyclass (FromJSON, ToJSON)
makeLenses ''WindowParams makeLenses ''WindowParams
makeLenses ''TWSConnection makeLenses ''TWSConnection
@ -83,7 +79,7 @@ instance Default Settings where
data TWSConnectionStatus = TWSDisconnected data TWSConnectionStatus = TWSDisconnected
| TWSConnecting | TWSConnecting
| TWSConnected | TWSConnected
deriving stock (Show, Eq, Enum, Bounded) deriving (Show, Eq, Enum, Bounded)
data TWSConnectionRefs = TWSConnectionRefs data TWSConnectionRefs = TWSConnectionRefs
{ twsConnectionRefsHost :: TVar Text { twsConnectionRefsHost :: TVar Text
@ -118,14 +114,14 @@ data IBAccount = IBAccount
{ _accountInfo :: IBAccountInfo { _accountInfo :: IBAccountInfo
, _accountPortfolio :: [IBPortfolioValue] , _accountPortfolio :: [IBPortfolioValue]
, _accountStrategies :: [IBAccountStrategy] , _accountStrategies :: [IBAccountStrategy]
} deriving stock (Show, Eq) } deriving (Show, Eq)
data IBAccountInfo = IBAccountInfo data IBAccountInfo = IBAccountInfo
{ _accountName :: Text { _accountName :: Text
, _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency) , _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency)
, _accountLastUpdate :: Text , _accountLastUpdate :: Text
} deriving stock (Show, Eq) } deriving (Show, Eq)
data IBPortfolioValue = IBPortfolioValue data IBPortfolioValue = IBPortfolioValue
{ _contract :: IBContract { _contract :: IBContract
@ -135,11 +131,10 @@ data IBPortfolioValue = IBPortfolioValue
, _averageCost :: Float , _averageCost :: Float
, _unrealizedPNL :: Float , _unrealizedPNL :: Float
, _realizedPNL :: Float , _realizedPNL :: Float
} deriving stock (Show, Eq) } deriving (Show, Eq)
newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy
deriving stock (Show) deriving (Show, Eq)
deriving newtype (Eq)
data IBSymbolSample = IBSymbolSample data IBSymbolSample = IBSymbolSample
{ _symbolId :: Int { _symbolId :: Int
@ -148,100 +143,63 @@ data IBSymbolSample = IBSymbolSample
, _primaryExchange :: Text , _primaryExchange :: Text
, _currency :: Text , _currency :: Text
, _derivatives :: [Text] , _derivatives :: [Text]
} deriving stock (Show, Eq) } deriving (Show, Eq)
makeLenses ''IBAccountStrategy makeLenses ''IBAccountStrategy
makeLenses ''IBAccountInfo makeLenses ''IBAccountInfo
makeLenses ''IBAccount makeLenses ''IBAccount
data ChartSettings = ChartSettings data ChartSettings = ChartSettings
{ chartResolution :: Int { chartResolution :: Int
, chartStart :: Maybe UTCTime , chartStart :: Maybe UTCTime
, chartEnd :: Maybe UTCTime , chartEnd :: Maybe UTCTime
, chartStudySettings :: [ChartStudyType] } deriving (Show, Eq)
} deriving stock (Show, Eq)
defChartSettings :: ChartSettings defChartSettings :: ChartSettings
defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect] defChartSettings = ChartSettings 60 Nothing Nothing
updateChartStudySettings :: Chart -> [ChartStudyType] -> Chart -- data TimeWindow = TimeWindow
updateChartStudySettings Chart{..} s = -- { begin :: Int
let chartSettings = chartSettings { chartStudySettings = [] } -- , end :: Int
chartCache = emptyChartCacheData chartCacheSettings -- } deriving (Show, Eq)
lastCacheUpdate = Nothing
in Chart{..}
-- | Settings for Chart-cache.
-- --
-- History and Resolution yield 1 day by default. Do not increase over 5000 as memery-consumption explodes! -- instance Semigroup TimeWindow where
-- Think of it as timePlotted = candleWidth * numberOfCandles -- (TimeWindow a b) <> (TimeWindow x y) = TimeWindow (min a x) (max b y)
-- --
-- chartCacheHistory should be a multiple of 20 as there often is 5% buffer in various caches and this -- instance Monoid TimeWindow where
-- fills the caches more optimally -- mempty = TimeWindow 0 86400
data ChartCacheSettings = ChartCacheSettings
{ chartCacheResolution :: Int
, chartCacheHistory :: Int
} deriving stock (Show, Eq)
defChartCacheSettings :: ChartCacheSettings
defChartCacheSettings = ChartCacheSettings 60 1440
-- TODO: TimePointFloat? or only 1 entry per second? -- TODO: TimePointFloat? or only 1 entry per second?
newtype TimePoint = TimePoint Int newtype TimePoint = TimePoint Int
deriving stock (Generic) deriving (Eq, Generic)
deriving newtype (Show, Eq, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON) deriving newtype (Show, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
deriving (Semigroup, Monoid) via (Max Int) deriving (Semigroup, Monoid) via (Max Int)
data ChartStudies = SMA { window :: Int, value :: Float } data ChartStudies = SMA { window :: Int, value :: Float }
| OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float} | OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float}
| Volume { volume :: Float } deriving (Show, Eq, Generic, FromJSON, ToJSON)
deriving stock (Show, Eq, Generic)
deriving anyclass (FromJSON, ToJSON)
data ChartPoint = ChartPoint data ChartPoint = ChartPoint
{ timeOfDay :: TimePoint { timeOfDay :: TimePoint
, pointValue :: Float , pointValue :: Float
, pointVolume :: Float , volume :: Int
, pointExtra :: [ChartStudies] , pointExtra :: [ChartStudies]
} deriving stock (Show, Eq, Generic) } deriving (Show, Eq, Generic, FromJSON, ToJSON)
deriving anyclass (FromJSON, ToJSON)
instance Measured TimePoint ChartPoint where instance Measured TimePoint ChartPoint where
measure = timeOfDay measure = timeOfDay
-- | Tick-based data
data ChartStudyType = ChartStudyTypeDirect
| ChartStudyTypeSMA Int
| ChartStudyTypeOpen
| ChartStudyTypeLow
| ChartStudyTypeHigh
| ChartStudyTypeClose
| ChartStudyTypeVolume
deriving stock (Show, Eq, Generic)
deriving anyclass (Hashable)
data ChartCacheData = ChartCacheData
{ chartCacheData :: HashMap ChartStudyType (VS.Vector Float)
, chartCacheAxis :: VS.Vector Float
, chartCacheCurrent :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
, chartCacheFilledTo :: Maybe (Int,Int) -- ^ in index into the vectors given range of "Current"
} deriving stock (Show, Eq)
emptyChartCacheData :: ChartCacheSettings -> ChartCacheData
emptyChartCacheData ChartCacheSettings{..} = ChartCacheData mempty (VS.replicate chartCacheHistory 0) Nothing Nothing
data Chart = Chart data Chart = Chart
{ chartContractID :: Int { chartContractID :: Int
, chartData :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale) , chartData :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale)
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale) , chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale)
, fillerThread :: ThreadId , fillerThread :: ThreadId
, chartSettings :: ChartSettings , chartSettings :: ChartSettings
, chartCacheSettings :: ChartCacheSettings , chartCache :: [ChartPoint] -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
, chartCache :: ChartCacheData -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings' , lastCacheUpdate :: Maybe TimePoint
, lastCacheUpdate :: Maybe TimePoint , chartDirty :: Bool
, chartDirty :: Bool } deriving (Show, Eq)
} deriving stock (Show, Eq)
newtype InjetiveGettable a b = InjetiveGettable newtype InjetiveGettable a b = InjetiveGettable
{ gettable :: TVar a { gettable :: TVar a