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

implemented #5

Browse Source
This commit is contained in:
Nicole Dresselhaus 2022-07-21 00:43:16 +02:00
parent 1848f0f2fc
commit 971f9d1651
8 changed files with 116 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -7,3 +7,4 @@ settings.json
*.lock
tags
dist-newstyle/
cache/*

2
deps/dear-implot.hs vendored

@ -1 +1 @@
Subproject commit ad5fdc1e646947c1365e725d29a43fc96dc98a66
Subproject commit 49539fc1ba04c590af0718066ce7a9aead8ff336

1
ibhelper.cabal
View File

@ -99,6 +99,7 @@ library
, gl
, managed
, microlens-th
, extra
, network
, pretty-show
, rio >=0.1.12.0

10
src/AppFiller.hs
View File

@ -11,7 +11,7 @@ import Data.Time
import Data.FingerTree
import Data.HashMap.Strict ((!?))
import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import qualified Debug.Trace as D
@ -28,11 +28,14 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
(Msg_IB_IN (IB_ManagedAccts as)) -> do
cur <- readTVarIO $ Types.accounts currentAppData
actions <- forM as $ \a -> case cur !? a of
Just _ -> return $ id
Just _ -> return id
Nothing -> do
debugMsg $ "added Account "<> a
return $ HM.insertWith const a (mkIBAccount a)
atomically $ modifyTVar (Types.accounts currentAppData) $ foldl' (.) id actions
run $ whenM (ask >>= (fmap isNothing . readTVarIO) . currentAccount . appRefs)
$ unless (L.null as)
$ switchAccountTo $ L.head as
(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
@ -58,7 +61,6 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
_ -> --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
@ -71,7 +73,7 @@ handleTickPrice IB_TickPrice{..} = do
case tickType of
IBTickType_Last_Price -> do
t <- utctDayTime <$> liftIO getCurrentTime
let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price []
let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price size []
liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True})
_ -> return ()
handleTickPrice _ = error "impossible"

47
src/Chart.hs
View File

@ -2,18 +2,21 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DerivingVia #-}
module Chart (newChart, FillerException(..)) where
module Chart (newChart, FillerException(..), getUpdatedChartCache) where
import Import
import Data.Time
import Data.Aeson (eitherDecodeFileStrict')
import RIO.List
import RIO.List.Partial
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.FingerTree as FT
import qualified Data.Text as T
import qualified Debug.Trace as D
@ -28,10 +31,20 @@ newChart :: IBContract -> RIO App ()
newChart contract = do
app <- ask
let sym = (symbol :: IBContract -> Text) contract
con = (conId :: IBContract -> Int) 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
let cacheFileName = "cache/"<> show con <>".json"
today <- liftIO getCurrentDay
cacheData <- liftIO $ ifM (doesFileExist cacheFileName)
(eitherDecodeFileStrict' cacheFileName)
(return $ Left $ "cachefile "<>cacheFileName<>" not found.")
(cacheData' :: HashMap Day (FingerTree TimePoint ChartPoint)) <- case cacheData of
Left err -> logError (display (T.pack $ "Error opening "<>cacheFileName<>".\n") <> displayShow err)
>> return HM.empty
Right (d :: HashMap Day [ChartPoint]) -> return $ FT.fromList <$> d
c <- liftIO $ newTVarIO $ Chart con (fromMaybe FT.empty $ cacheData' HM.!? today) mempty undefined defChartSettings [] Nothing False
tid <- liftIO $ forkIO $ fillChart app contract c
liftIO $ atomically $ do
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
@ -54,10 +67,17 @@ fillChart app contract cVar = runRIO app $ do
handle (\QuitFiller -> cancelSubscription >> exitSuccess) $
forever $ do
-- chart dirty? set clean & begin work
Chart{..} <- liftIO (readTVarIO cVar)
when chartDirty $ do
c <- liftIO (readTVarIO cVar)
when (chartDirty c) $ do
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartDirty = False })
let (TimePoint cacheUpdateStart) = fromMaybe (TimePoint 0) Nothing -- TODO: lastCacheUpdate
let (lUpdate, cachePoints) = getUpdatedChartCache c Nothing
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartCache = cachePoints, lastCacheUpdate = lUpdate })
return ()
threadDelay 1000000 -- sleep 5 seconds
getUpdatedChartCache :: Chart -> Maybe ChartSettings -> (Maybe TimePoint, [ChartPoint])
getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart)
where (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
@ -72,18 +92,17 @@ fillChart app contract cVar = runRIO app $ do
| 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
chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution $ fromMaybe chartSettings chartSettings') chartData
lUpdate = fmap fst . lastMaybe $ chunkedChart
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
toCachePoint (t,[]) = ChartPoint t (-1) []
toCachePoint (t,as) = ChartPoint t c [OLHC o l h c]
toCachePoint (t,[]) = ChartPoint t (-1) 0 []
toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
where
vol = sum $ volume <$> as
as' = pointValue <$> as
ms' = sum $ (\x -> pointValue x * fromIntegral (volume x)) <$> as
m = ms' / fromIntegral vol
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

22
src/Import.hs
View File

@ -6,7 +6,10 @@ module Import
, module Data.Default
, module Text.Show.Pretty
, module IBClient.Types
, module System.Directory
, ppShow'
, getCurrentDay
, switchAccountTo
) where
import RIO
@ -15,10 +18,29 @@ import Data.Aeson (FromJSON, ToJSON)
import Data.Default
import Text.Show.Pretty
import IBClient.Types
import System.Directory
--- imports not reexported
import Data.Text as T
import Data.Time.Clock
import Data.Time.Calendar
ppShow' :: Show a => a -> Text
ppShow' = T.pack . ppShow
getCurrentDay :: IO Day
getCurrentDay = utctDay <$> getCurrentTime
switchAccountTo :: Text -> RIO App ()
switchAccountTo a = do
refs' <- appRefs <$> ask
let sendQ = twsConnectionSend $ twsConnectionRefs refs'
-- 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)

37
src/Run.hs
View File

@ -14,14 +14,17 @@ import DearImGui
import DearImGui.Plot
import DearImGui.OpenGL3
import DearImGui.SDL
import Data.Time.Clock
import Graphics.GL
import SDL
import Data.StateVar
--import Data.StateVar
import qualified Data.Text as T
import qualified Data.List as L
import qualified Data.HashMap.Strict as HM
import qualified Data.FingerTree as FT
--import qualified Data.FingerTree as FT
import IBClient.Connection
import Import (Chart(chartContractID))
run :: RIO App ()
run = do
@ -47,7 +50,18 @@ shutdownApp = do
liftIO $ encodeFile "settings.json" settings'
logInfo $ display ("Settings Saved" :: Text)
-- save cached data
liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache"
charts <- liftIO . readTVarIO . appCharts $ refs
forM_ (HM.toList charts) $ \(symbol,tc) -> do
c@Chart{..} <- liftIO . readTVarIO $ tc
today <- liftIO $ utctDay <$> getCurrentTime
let (_, chartData') = getUpdatedChartCache c (Just $ ChartSettings 5 Nothing Nothing)
merge a b = a <> b --TODO: merge duplicates!
newData = HM.alter (\case
Just t -> Just (merge t chartData')
Nothing -> Just chartData') today (toList <$> chartHistData)
newData' = filter (\ChartPoint{..} -> 0 /= volume) <$> newData
liftIO $ encodeFile ("cache/"<> show chartContractID <>".json") newData'
logInfo $ display $ ppShow' settings'
renderLoop :: RIO App ()
@ -91,15 +105,7 @@ renderLoop = do
forM_ accs $ \a -> do
selectable 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)
True -> switchAccountTo a
let cStatus = twsConnectionStatus cr
connHost <- liftIO $ readTVarIO $ twsConnectionRefsHost cr
connPort <- liftIO $ readTVarIO $ twsConnectionRefsPort cr
@ -222,8 +228,11 @@ renderLoop = do
case viewr chartData of
EmptyR -> text "no last price"
(_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay
text $ ppShow' chartCache
text $ ppShow' lastCacheUpdate
withPlot "Test" $ do
-- TODO: set axes
let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
plotLine (T.unpack symbol) x y
return ()
return ()

18
src/Types.hs
View File

@ -169,30 +169,34 @@ defChartSettings = ChartSettings 60 Nothing Nothing
-- instance Monoid TimeWindow where
-- mempty = TimeWindow 0 86400
-- TODO: TimePointFloat? or only 1 entry per second?
newtype TimePoint = TimePoint Int
deriving Eq
deriving newtype Show
deriving (Eq, Generic)
deriving newtype (Show, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
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)
deriving (Show, Eq, Generic, FromJSON, ToJSON)
data ChartPoint = ChartPoint
{ timeOfDay :: TimePoint
, pointValue :: Float
, volume :: Int
, pointExtra :: [ChartStudies]
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, FromJSON, ToJSON)
instance Measured TimePoint ChartPoint where
measure = timeOfDay
data Chart = Chart
{ chartData :: FingerTree TimePoint ChartPoint
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint)
{ chartContractID :: Int
, chartData :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale)
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale)
, fillerThread :: ThreadId
, chartSettings :: ChartSettings
, chartCache :: [ChartPoint]
, chartCache :: [ChartPoint] -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
, lastCacheUpdate :: Maybe TimePoint
, chartDirty :: Bool
} deriving (Show, Eq)