<commit_before>{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,
             FlexibleInstances, FlexibleContexts, MultiParamTypeClasses  #-}
module Distribution.Server.Caches
    ( fetchPackagesPage
    , fetchIndexTarball
    , cacheThread
    ) where

import Data.ByteString.Lazy as Lazy
import Data.Dynamic
import Data.IORef
import Control.Concurrent
import Control.Exception
import System.IO.Unsafe

import HAppS.State
import HAppS.Data
import HAppS.Server

import Distribution.Server.PackagesState
import Distribution.Server.Pages.Index

data Cache = Cache {
       cachePackagesPage :: Response,
       cacheIndexTarball :: ByteString
     } deriving (Typeable)

{-# NOINLINE cacheEnv #-}
cacheEnv :: IORef Cache
cacheEnv = unsafePerformIO $ newIORef $ error "Distribution.Server.Caches: cache not initialized."

fetchPackagesPage :: IO Response
fetchPackagesPage = fmap cachePackagesPage (readIORef cacheEnv)

fetchIndexTarball :: IO ByteString
fetchIndexTarball = fmap cacheIndexTarball (readIORef cacheEnv)

cacheThread :: IO ()
cacheThread = do updateCache
                 getEvent <- getEventStream
                 let loop = do item <- getEvent
                               case fromDynamic (eventData item) of
                                 Just BulkImport{}
                                     -> do takeMVar (eventFinished item)
                                           updateCache
                                 _   -> return ()
                               loop
                 forkIO $ loop
                 return ()


updateCache = do state <- query $ GetPackagesState
                 let pkgIndex = generatePackageIndex (packageList state)
                     packagePage = toResponse (packageIndex (packageList state))
                 -- FIXME: compute in parallel
                 evaluate $ Lazy.length pkgIndex
                 evaluate $ Lazy.length (rsBody packagePage)
                 atomicModifyIORef cacheEnv $ \cache -> (cache { cacheIndexTarball = pkgIndex
                                                               , cachePackagesPage = packagePage }
                                                        ,())

<commit_msg>Overwrite the old cache instead of updating it.<commit_after>{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,
             FlexibleInstances, FlexibleContexts, MultiParamTypeClasses  #-}
module Distribution.Server.Caches
    ( fetchPackagesPage
    , fetchIndexTarball
    , cacheThread
    ) where

import Data.ByteString.Lazy as Lazy
import Data.Dynamic
import Data.IORef
import Control.Concurrent
import Control.Exception
import System.IO.Unsafe

import HAppS.State
import HAppS.Data
import HAppS.Server

import Distribution.Server.PackagesState
import Distribution.Server.Pages.Index

data Cache = Cache {
       cachePackagesPage :: Response,
       cacheIndexTarball :: ByteString
     } deriving (Typeable)

{-# NOINLINE cacheEnv #-}
cacheEnv :: IORef Cache
cacheEnv = unsafePerformIO $ newIORef $ error "Distribution.Server.Caches: cache not initialized."

fetchPackagesPage :: IO Response
fetchPackagesPage = fmap cachePackagesPage (readIORef cacheEnv)

fetchIndexTarball :: IO ByteString
fetchIndexTarball = fmap cacheIndexTarball (readIORef cacheEnv)

cacheThread :: IO ()
cacheThread = do updateCache
                 getEvent <- getEventStream
                 let loop = do item <- getEvent
                               case fromDynamic (eventData item) of
                                 Just BulkImport{}
                                     -> do takeMVar (eventFinished item)
                                           updateCache
                                 _   -> return ()
                               loop
                 forkIO $ loop
                 return ()


updateCache = do state <- query $ GetPackagesState
                 let pkgIndex = generatePackageIndex (packageList state)
                     packagePage = toResponse (packageIndex (packageList state))
                 -- FIXME: compute in parallel
                 evaluate $ Lazy.length pkgIndex
                 evaluate $ Lazy.length (rsBody packagePage)
                 atomicModifyIORef cacheEnv $ \_ -> (Cache { cacheIndexTarball = pkgIndex
                                                           , cachePackagesPage = packagePage }
                                                    ,())


{'fraction_non_alphanumeric': 0.06048935206162211, 'fraction_numerical': 0.0, 'mean_word_length': 1.8067387158296249, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 18, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2202663', 'n_tokens_mistral': 1065, 'n_tokens_neox': 1024, 'n_words': 284}