{-# LANGUAGE BangPatterns #-}
module Hackage.Security.Client.Repository.Cache (
Cache(..)
, getCached
, getCachedRoot
, getCachedIndex
, clearCache
, withIndex
, getIndexIdx
, cacheRemoteFile
, lockCache
) where
import Control.Exception
import Control.Monad
import Data.Maybe
import Codec.Archive.Tar (Entries(..))
import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset)
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.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 :: Path Absolute
, cacheLayout :: CacheLayout
}
cacheRemoteFile :: forall down typ f. DownloadedFile down
=> Cache -> down typ -> Format f -> IsCached typ -> IO ()
cacheRemoteFile cache downloaded f isCached = do
go f isCached
case isCached of
CacheIndex -> rebuildTarIndex cache
_otherwise -> return ()
where
go :: Format f -> IsCached typ -> IO ()
go _ DontCache = return ()
go FUn (CacheAs file) = copyTo (cachedFilePath cache file)
go FGz CacheIndex = copyTo (cachedIndexPath cache FGz) >> unzipIndex
go _ _ = error "cacheRemoteFile: unexpected case"
copyTo :: Path Absolute -> IO ()
copyTo fp = do
createDirectoryIfMissing True (takeDirectory fp)
downloadedCopyTo downloaded fp
unzipIndex :: IO ()
unzipIndex = do
createDirectoryIfMissing True (takeDirectory indexUn)
shouldTryIncremenal <- cachedIndexProbablyValid
if shouldTryIncremenal
then unzipIncremenal
else unzipNonIncremenal
where
unzipIncremenal = do
compressed <- readLazyByteString indexGz
let uncompressed = GZip.decompress compressed
withFile indexUn ReadWriteMode $ \h -> do
currentSize <- hFileSize h
let seekTo = 0 `max` (currentSize - tarTrailer)
hSeek h AbsoluteSeek seekTo
BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed
unzipNonIncremenal = do
compressed <- readLazyByteString indexGz
let uncompressed = GZip.decompress compressed
withFile indexUn WriteMode $ \h ->
BS.L.hPut h uncompressed
void . handleDoesNotExist $
removeFile indexIdx
cachedIndexProbablyValid :: IO Bool
cachedIndexProbablyValid =
fmap (fromMaybe False) $
handleDoesNotExist $ do
tsUn <- getModificationTime indexUn
tsIdx <- getModificationTime indexIdx
return (tsIdx >= tsUn)
indexGz = cachedIndexPath cache FGz
indexUn = cachedIndexPath cache FUn
indexIdx = cachedIndexIdxPath cache
tarTrailer :: Integer
tarTrailer = 1024
rebuildTarIndex :: Cache -> IO ()
rebuildTarIndex cache = do
(builder, offset) <- initBuilder <$> tryReadIndex (cachedIndexIdxPath cache)
withFile (cachedIndexPath cache FUn) ReadMode $ \hTar -> do
TarIndex.hSeekEntryOffset hTar offset
newEntries <- Tar.read <$> BS.L.hGetContents hTar
case addEntries builder newEntries of
Left ex -> throwUnchecked ex
Right idx -> withFile (cachedIndexIdxPath cache) WriteMode $ \hIdx -> do
hSetBuffering hIdx (BlockBuffering Nothing)
BS.hPut hIdx $ TarIndex.serialise idx
where
initBuilder :: Either e TarIndex -> (IndexBuilder, TarEntryOffset)
initBuilder (Left _) = ( TarIndex.empty, 0 )
initBuilder (Right idx) = ( TarIndex.unfinalise idx
, TarIndex.indexEndEntryOffset idx
)
getCached :: Cache -> CachedFile -> IO (Maybe (Path Absolute))
getCached cache cachedFile = do
exists <- doesFileExist localPath
if exists then return $ Just localPath
else return $ Nothing
where
localPath = cachedFilePath cache cachedFile
getCachedIndex :: Cache -> Format f -> IO (Maybe (Path Absolute))
getCachedIndex cache format = do
exists <- doesFileExist localPath
if exists then return $ Just localPath
else return $ Nothing
where
localPath = cachedIndexPath cache format
getCachedRoot :: Cache -> IO (Path Absolute)
getCachedRoot cache = do
mPath <- getCached cache CachedRoot
case mPath of
Just p -> return p
Nothing -> internalError "Client missing root info"
getIndexIdx :: Cache -> IO TarIndex
getIndexIdx cache = do
mIndex <- tryReadIndex $ cachedIndexIdxPath cache
case mIndex of
Left _ -> throwIO $ userError "Could not read index. Did you call 'checkForUpdates'?"
Right idx -> return idx
withIndex :: Cache -> (Handle -> IO a) -> IO a
withIndex cache = withFile (cachedIndexPath cache FUn) ReadMode
clearCache :: Cache -> IO ()
clearCache cache = void . handleDoesNotExist $ do
removeFile $ cachedFilePath cache CachedTimestamp
removeFile $ cachedFilePath cache CachedSnapshot
lockCache :: Cache -> IO () -> IO ()
lockCache Cache{..} = withDirLock cacheRoot
addEntries :: IndexBuilder -> Entries e -> Either e TarIndex
addEntries = go
where
go !builder (Next e es) = go (TarIndex.addNextEntry e builder) es
go !builder Done = Right $! TarIndex.finalise builder
go !_ (Fail err) = Left err
tryReadIndex :: Path Absolute -> 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
cachedFilePath :: Cache -> CachedFile -> Path Absolute
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
cachedIndexPath :: Cache -> Format f -> Path Absolute
cachedIndexPath Cache{..} format =
anchorCachePath cacheRoot $ go format
where
go :: Format f -> CachePath
go FUn = cacheLayoutIndexTar cacheLayout
go FGz = cacheLayoutIndexTarGz cacheLayout
cachedIndexIdxPath :: Cache -> Path Absolute
cachedIndexIdxPath Cache{..} =
anchorCachePath cacheRoot $ cacheLayoutIndexIdx cacheLayout