implemented #5

2022-07-21 00:43:16 +02:00 · 2022-07-21 00:43:16 +02:00 · 971f9d1651
commit 971f9d1651
parent 1848f0f2fc
8 changed files with 116 additions and 58 deletions
--- a/.gitignore
+++ b/.gitignore
@ -7,3 +7,4 @@ settings.json
 *.lock
 tags
 dist-newstyle/
+cache/*
--- a/deps/dear-implot.hs
+++ b/deps/dear-implot.hs
@ -1 +1 @@
-Subproject commit ad5fdc1e646947c1365e725d29a43fc96dc98a66
+Subproject commit 49539fc1ba04c590af0718066ce7a9aead8ff336
--- a/ibhelper.cabal
+++ b/ibhelper.cabal
@ -99,6 +99,7 @@ library
    , gl
    , managed
    , microlens-th
+    , extra
    , network
    , pretty-show
    , rio >=0.1.12.0
--- a/src/AppFiller.hs
+++ b/src/AppFiller.hs
@ -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"
--- a/src/Chart.hs
+++ b/src/Chart.hs
@ -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,36 +67,42 @@ 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
-              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
+          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
+              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 $ fromMaybe chartSettings chartSettings') chartData
+          lUpdate = fmap fst . lastMaybe $ chunkedChart
+          toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
+          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'
--- a/src/Import.hs
+++ b/src/Import.hs
@ -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)
--- a/src/Run.hs
+++ b/src/Run.hs
@ -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 ()


--- a/src/Types.hs
+++ b/src/Types.hs
@ -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)