implemented #5

.gitignore

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

deps/dear-implot.hs

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

ibhelper.cabal

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

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"

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)
+        c <- liftIO (readTVarIO cVar)
-        when chartDirty $ do
+        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
-              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
+
+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'

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)

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
+            True  -> switchAccountTo a
-              -- 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
@@ -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
+        withPlot "Test" $ do
-        text $ ppShow' lastCacheUpdate
+          -- TODO: set axes
+          let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
+          plotLine (T.unpack symbol) x y
+          return ()
         return ()
 
 

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 (Eq, Generic)
-  deriving newtype Show
+  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
+           { chartContractID :: Int
-           , chartHistData   :: HashMap Day (FingerTree TimePoint ChartPoint)
+           , 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)