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 ()