module Hackage.Security.Client.Repository.Cache (
Cache(..)
, getCached
, getCachedRoot
, getCachedIndex
, clearCache
, getFromIndex
, cacheRemoteFile
) where
import Control.Exception
import Control.Monad
import Codec.Archive.Tar.Index (TarIndex)
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Index as TarIndex
import qualified Codec.Compression.GZip as GZip
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BS.Builder
import qualified Data.ByteString.Lazy as BS.L
import Hackage.Security.Client.Repository
import Hackage.Security.Client.Formats
import Hackage.Security.TUF
import Hackage.Security.Util.Checked
import Hackage.Security.Util.IO
import Hackage.Security.Util.Path
data Cache = Cache {
cacheRoot :: AbsolutePath
, cacheLayout :: CacheLayout
}
cacheRemoteFile :: Cache -> TempPath -> Format f -> IsCached -> IO ()
cacheRemoteFile cache tempPath f isCached = do
go f isCached
when (isCached == CacheIndex) $ rebuildTarIndex cache
where
go :: Format f -> IsCached -> IO ()
go _ DontCache = return ()
go FUn (CacheAs cachedFile) = do copyTo $ cachedFilePath cache cachedFile
go FGz (CacheAs cachedFile) = do ungzTo $ cachedFilePath cache cachedFile
go FUn CacheIndex = do copyTo $ cachedIndexTarPath cache
go FGz CacheIndex = do ungzTo $ cachedIndexTarPath cache
case cachedIndexTarGzPath cache of
Nothing -> return ()
Just tarGzPath -> copyTo tarGzPath
copyTo :: AbsolutePath -> IO ()
copyTo fp = do
createDirectoryIfMissing True (takeDirectory fp)
atomicCopyFile tempPath fp
ungzTo :: AbsolutePath -> IO ()
ungzTo fp = do
createDirectoryIfMissing True (takeDirectory fp)
compressed <- readLazyByteString tempPath
atomicWriteFile fp $ GZip.decompress compressed
rebuildTarIndex :: Cache -> IO ()
rebuildTarIndex cache = do
entries <- Tar.read <$> readLazyByteString (cachedIndexTarPath cache)
case TarIndex.build entries of
Left ex -> throwUnchecked ex
Right index ->
atomicWithFile (cachedIndexIdxPath cache) $ \h -> do
hSetBuffering h (BlockBuffering Nothing)
BS.Builder.hPutBuilder h $ TarIndex.serialise index
getCached :: Cache -> CachedFile -> IO (Maybe AbsolutePath)
getCached cache cachedFile = do
exists <- doesFileExist localPath
if exists then return $ Just localPath
else return $ Nothing
where
localPath = cachedFilePath cache cachedFile
getCachedIndex :: Cache -> IO (Maybe AbsolutePath)
getCachedIndex cache = do
exists <- doesFileExist localPath
if exists then return $ Just localPath
else return $ Nothing
where
localPath = cachedIndexTarPath cache
getCachedRoot :: Cache -> IO AbsolutePath
getCachedRoot cache = do
mPath <- getCached cache CachedRoot
case mPath of
Just p -> return p
Nothing -> internalError "Client missing root info"
getFromIndex :: Cache -> IndexLayout -> IndexFile -> IO (Maybe BS.ByteString)
getFromIndex cache indexLayout indexFile = do
mIndex <- tryReadIndex (cachedIndexIdxPath cache)
case mIndex of
Left _err -> do
rebuildTarIndex cache
getFromIndex cache indexLayout indexFile
Right index ->
case tarIndexLookup index (tarPath (indexFilePath indexLayout indexFile)) of
Just (TarIndex.TarFileEntry offset) ->
withFileInReadMode (cachedIndexTarPath cache) $ \h -> do
entry <- TarIndex.hReadEntry h offset
case Tar.entryContent entry of
Tar.NormalFile lbs _size -> do
bs <- evaluate $ BS.concat . BS.L.toChunks $ lbs
return $ Just bs
_otherwise ->
return Nothing
_otherwise ->
return Nothing
where
tarPath :: IndexPath -> TarballPath
tarPath = castRoot
tryReadIndex :: AbsolutePath -> IO (Either (Maybe IOException) TarIndex)
tryReadIndex fp =
aux <$> try (TarIndex.deserialise <$> readStrictByteString fp)
where
aux :: Either e (Maybe (a, leftover)) -> Either (Maybe e) a
aux (Left e) = Left (Just e)
aux (Right Nothing) = Left Nothing
aux (Right (Just (a, _))) = Right a
clearCache :: Cache -> IO ()
clearCache cache = void . handleDoesNotExist $ do
removeFile $ cachedFilePath cache CachedTimestamp
removeFile $ cachedFilePath cache CachedSnapshot
cachedFilePath :: Cache -> CachedFile -> AbsolutePath
cachedFilePath Cache{cacheLayout=CacheLayout{..}, ..} file =
anchorCachePath cacheRoot $ go file
where
go :: CachedFile -> CachePath
go CachedRoot = cacheLayoutRoot
go CachedTimestamp = cacheLayoutTimestamp
go CachedSnapshot = cacheLayoutSnapshot
go CachedMirrors = cacheLayoutMirrors
cachedIndexTarPath :: Cache -> AbsolutePath
cachedIndexTarPath Cache{..} =
anchorCachePath cacheRoot $ cacheLayoutIndexTar cacheLayout
cachedIndexTarGzPath :: Cache -> Maybe AbsolutePath
cachedIndexTarGzPath Cache{..} =
fmap (anchorCachePath cacheRoot) $ cacheLayoutIndexTarGz cacheLayout
cachedIndexIdxPath :: Cache -> AbsolutePath
cachedIndexIdxPath Cache{..} =
anchorCachePath cacheRoot $ cacheLayoutIndexIdx cacheLayout