module Data.LazyHash.Cache (
cached, cached'
, fundamental, (<#>), liftPH2
, CacheAccessConf, cachingLocation
, usePrecalculated
, calculateIfNecessary
, writeUsedVersion
, burnAfterReading
, cachedValueInFile
) where
import Data.LazyHash.Class
import Data.LazyHash.Numerical ()
import qualified Data.Hashable as SH
import Data.Binary
import System.FilePath
import System.Directory
import System.IO
import System.IO.Temp
import Control.Exception (bracket)
import Control.Monad
import Data.Binary
import Data.Typeable
import qualified Data.ByteString.Char8 as BS hiding (hPut)
import qualified Data.ByteString.Lazy as BS (toStrict, hPut)
import qualified Data.ByteString.Base16 as B16
import Data.Default.Class
import Lens.Micro
import Lens.Micro.TH
data CacheAccessConf = CachAccConf {
_cachingLocation :: Maybe FilePath
, _usePrecalculated, _calculateIfNecessary
, _writeUsedVersion, _burnAfterReading :: Bool
}
makeLensesWith (lensRules & generateSignatures.~False) ''CacheAccessConf
cachingLocation :: Lens' CacheAccessConf (Maybe FilePath)
usePrecalculated :: Lens' CacheAccessConf Bool
calculateIfNecessary :: Lens' CacheAccessConf Bool
writeUsedVersion :: Lens' CacheAccessConf Bool
burnAfterReading :: Lens' CacheAccessConf Bool
instance Default CacheAccessConf where
def = CachAccConf (Just ".hscache/lazy-hashed") True True True False
cached :: (Hash h, Binary a, Typeable a, Binary h) => Prehashed h a -> IO a
cached = cached' def
cached' :: (Hash h, Binary a, Typeable a, Binary h)
=> CacheAccessConf
-> Prehashed h a
-> IO a
cached' conf@(CachAccConf Nothing _ _ _ _) v = do
tmpRoot <- getTemporaryDirectory
cached' (conf & cachingLocation .~ Just (tmpRoot</>"hs-lazy-hashed")) v
cached' conf@(CachAccConf (Just path) reuse calcNew writeUsed burnAfterReading)
(Prehashed h v) = do
let fname = path </> (BS.unpack . B16.encode . BS.toStrict . encode
$ h # typeRep [v]) <.> ".lhbs"
cachedValueInFile conf fname v
cachedValueInFile :: Binary a
=> CacheAccessConf
-> FilePath
-> a
-> IO a
cachedValueInFile (CachAccConf _ reuse calcNew writeUsed burn) fname v
= doesFileExist fname >>= \case
True | reuse -> do
vMemoized <- decodeFile fname
when burn $ removeFile fname
return vMemoized
_ | calcNew -> do
when writeUsed $ do
let storageDir = takeDirectory fname
wipDir = storageDir</>"wip"
createDirectoryIfMissing True storageDir
createDirectoryIfMissing True wipDir
bracket
( openBinaryTempFile wipDir (takeFileName fname++".") )
( \(_, h) -> hClose h )
( \(tmpFname, h) -> do
BS.hPut h $ encode v
renameFile tmpFname fname
)
return v
False -> error "Requested value from cache that is not there. Perhaps enable `calculateIfNecessary`?"