From 30a1fb33ffe494ea08880fbfa181d0fb19bb244e Mon Sep 17 00:00:00 2001
From: Stefan Dresselhaus <stefan@dresselhaus.cloud>
Date: Thu, 21 Jul 2022 18:59:13 +0200
Subject: [PATCH] cache now is not monolithic, but 1 file per day.

---
 src/Chart.hs | 27 ++++++++++++++++-----------
 src/Run.hs   |  4 +++-
 2 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/src/Chart.hs b/src/Chart.hs
index 2aa1c6d..0054d01 100644
--- a/src/Chart.hs
+++ b/src/Chart.hs
@@ -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)
-                              (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
+    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.")
+        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{..})
diff --git a/src/Run.hs b/src/Run.hs
index 7f00a38..0df3b44 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -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 ()