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

cache now is not monolithic, but 1 file per day.

Browse Source
This commit is contained in:
Nicole Dresselhaus 2022-07-21 18:59:13 +02:00
parent 971f9d1651
commit 30a1fb33ff
2 changed files with 19 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Chart.hs
View File

@ -1,13 +1,15 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
module Chart (newChart, FillerException(..), getUpdatedChartCache) where
import Import
import Data.Aeson (eitherDecodeFileStrict')
import RIO.List
import RIO.List.Partial
import RIO.FilePath
import Data.Time.Calendar (Day(..))
import Data.FingerTree (FingerTree)
import Control.Concurrent (forkIO)
@ -35,16 +37,19 @@ newChart contract = do
hmVar = appCharts . appRefs $ app
hm <- liftIO . readTVarIO $ hmVar
unless (sym `HM.member` hm) $ do
let cacheFileName = "cache/"<> show con <>".json"
today <- liftIO getCurrentDay
cacheData <- liftIO $ ifM (doesFileExist cacheFileName)
(eitherDecodeFileStrict' cacheFileName)
today <- liftIO getCurrentDay :: RIO App Day
(cacheErrors, cacheData) <- do
files <- liftIO $ listDirectory $ "cache" </> show con
res <- forM files $ \cacheFileName -> do
let fname = "cache" </> show con </> cacheFileName
ifM (liftIO $ doesFileExist $ fname)
(bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname))
(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
return $ partitionEithers res
unless (null cacheErrors) $ forM_ cacheErrors $ \err -> logError (displayShow err)
let cacheData' :: HashMap Day (FingerTree TimePoint ChartPoint) = HM.fromList $ bimap (fromMaybe today) FT.fromList <$> cacheData
logError $ displayShow $ HM.keys cacheData'
c <- liftIO $ newTVarIO $ Chart con (fromMaybe FT.empty $ cacheData' HM.!? today) (HM.delete today cacheData') undefined defChartSettings [] Nothing False
tid <- liftIO $ forkIO $ fillChart app contract c
liftIO $ atomically $ do
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})

4
src/Run.hs
View File

@ -55,13 +55,15 @@ shutdownApp = do
forM_ (HM.toList charts) $ \(symbol,tc) -> do
c@Chart{..} <- liftIO . readTVarIO $ tc
today <- liftIO $ utctDay <$> getCurrentTime
liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID
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'
forM_ (HM.toList newData') $ \(day, dat) -> do
liftIO $ encodeFile ("cache/" <> show chartContractID <> "/" <> show day <> ".json") dat
logInfo $ display $ ppShow' settings'
renderLoop :: RIO App ()