{-# LANGUAGE BangPatterns #-}
module Hackage.Security.Client.Repository.Cache (
Cache(..)
, getCached
, getCachedRoot
, getCachedIndex
, clearCache
, withIndex
, getIndexIdx
, cacheRemoteFile
, lockCache
, lockCacheWithLogger
) where
import MyPrelude
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
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.Exit
import Hackage.Security.Util.IO
import Hackage.Security.Util.Path
data Cache = Cache {
Cache -> Path Absolute
cacheRoot :: Path Absolute
, Cache -> CacheLayout
cacheLayout :: CacheLayout
}
cacheRemoteFile :: forall down typ f. DownloadedFile down
=> Cache -> down typ -> Format f -> IsCached typ -> IO ()
cacheRemoteFile :: forall (down :: * -> *) typ f.
DownloadedFile down =>
Cache -> down typ -> Format f -> IsCached typ -> IO ()
cacheRemoteFile Cache
cache down typ
downloaded Format f
f IsCached typ
isCached = do
Format f -> IsCached typ -> IO ()
go Format f
f IsCached typ
isCached
case IsCached typ
isCached of
IsCached typ
CacheIndex -> Cache -> IO ()
rebuildTarIndex Cache
cache
IsCached typ
_otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
go :: Format f -> IsCached typ -> IO ()
go :: Format f -> IsCached typ -> IO ()
go Format f
_ IsCached typ
DontCache = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go Format f
FUn (CacheAs CachedFile
file) = Path Absolute -> IO ()
copyTo (Cache -> CachedFile -> Path Absolute
cachedFilePath Cache
cache CachedFile
file)
go Format f
FGz IsCached typ
CacheIndex = Path Absolute -> IO ()
copyTo (forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatGz
FGz) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
unzipIndex
go Format f
_ IsCached typ
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"cacheRemoteFile: unexpected case"
copyTo :: Path Absolute -> IO ()
copyTo :: Path Absolute -> IO ()
copyTo Path Absolute
fp = do
forall root. FsRoot root => Bool -> Path root -> IO ()
createDirectoryIfMissing Bool
True (forall a. Path a -> Path a
takeDirectory Path Absolute
fp)
forall (down :: * -> *) a.
DownloadedFile down =>
down a -> Path Absolute -> IO ()
downloadedCopyTo down typ
downloaded Path Absolute
fp
unzipIndex :: IO ()
unzipIndex :: IO ()
unzipIndex = do
forall root. FsRoot root => Bool -> Path root -> IO ()
createDirectoryIfMissing Bool
True (forall a. Path a -> Path a
takeDirectory Path Absolute
indexUn)
Bool
shouldTryIncremental <- IO Bool
cachedIndexProbablyValid
if Bool
shouldTryIncremental
then do
Bool
success <- IO Bool
unzipIncremental
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success IO ()
unzipNonIncremental
else IO ()
unzipNonIncremental
where
unzipIncremental :: IO Bool
unzipIncremental = do
ByteString
compressed <- forall root. FsRoot root => Path root -> IO ByteString
readLazyByteString Path Absolute
indexGz
let uncompressed :: ByteString
uncompressed = ByteString -> ByteString
GZip.decompress ByteString
compressed
(Integer
seekTo',ByteString
newTail') <- forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
indexUn IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
forall (m :: * -> *) a. Monad m => ExceptT a m a -> m a
multipleExitPoints forall a b. (a -> b) -> a -> b
$ do
Integer
currentSize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO Integer
hFileSize Handle
h
let seekTo :: Integer
seekTo = Integer
0 forall a. Ord a => a -> a -> a
`max` (Integer
currentSize forall a. Num a => a -> a -> a
- Integer
tarTrailer)
(ByteString
newPrefix,ByteString
newTail) = Int64 -> ByteString -> (ByteString, ByteString)
BS.L.splitAt (forall a. Num a => Integer -> a
fromInteger Integer
seekTo)
ByteString
uncompressed
(ByteString
oldPrefix,ByteString
oldTrailer) <- Int64 -> ByteString -> (ByteString, ByteString)
BS.L.splitAt (forall a. Num a => Integer -> a
fromInteger Integer
seekTo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ByteString
BS.L.hGetContents Handle
h)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
oldPrefix forall a. Eq a => a -> a -> Bool
== ByteString
newPrefix) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (Integer
0,forall a. Monoid a => a
mempty)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
oldTrailer forall a. Eq a => a -> a -> Bool
== ByteString
tarTrailerBs) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (Integer
0,forall a. Monoid a => a
mempty)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
seekTo,ByteString
newTail)
if Integer
seekTo' forall a. Ord a => a -> a -> Bool
<= Integer
0
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
indexUn IOMode
ReadWriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
seekTo'
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.L.hPut Handle
h ByteString
newTail'
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
unzipNonIncremental :: IO ()
unzipNonIncremental = do
ByteString
compressed <- forall root. FsRoot root => Path root -> IO ByteString
readLazyByteString Path Absolute
indexGz
let uncompressed :: ByteString
uncompressed = ByteString -> ByteString
GZip.decompress ByteString
compressed
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
indexUn IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
Handle -> ByteString -> IO ()
BS.L.hPut Handle
h ByteString
uncompressed
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Maybe a)
handleDoesNotExist forall a b. (a -> b) -> a -> b
$
forall root. FsRoot root => Path root -> IO ()
removeFile Path Absolute
indexIdx
cachedIndexProbablyValid :: IO Bool
cachedIndexProbablyValid :: IO Bool
cachedIndexProbablyValid =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe Bool
False) forall a b. (a -> b) -> a -> b
$
forall a. IO a -> IO (Maybe a)
handleDoesNotExist forall a b. (a -> b) -> a -> b
$ do
UTCTime
tsUn <- forall root. FsRoot root => Path root -> IO UTCTime
getModificationTime Path Absolute
indexUn
UTCTime
tsIdx <- forall root. FsRoot root => Path root -> IO UTCTime
getModificationTime Path Absolute
indexIdx
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
tsIdx forall a. Ord a => a -> a -> Bool
>= UTCTime
tsUn)
indexGz :: Path Absolute
indexGz = forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatGz
FGz
indexUn :: Path Absolute
indexUn = forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatUn
FUn
indexIdx :: Path Absolute
indexIdx = Cache -> Path Absolute
cachedIndexIdxPath Cache
cache
tarTrailer :: Integer
tarTrailer :: Integer
tarTrailer = Integer
1024
tarTrailerBs :: ByteString
tarTrailerBs = Int64 -> Word8 -> ByteString
BS.L.replicate (forall a. Num a => Integer -> a
fromInteger Integer
tarTrailer) Word8
0x00
rebuildTarIndex :: Cache -> IO ()
rebuildTarIndex :: Cache -> IO ()
rebuildTarIndex Cache
cache = do
(IndexBuilder
builder, TarEntryOffset
offset) <- forall e. Either e TarIndex -> (IndexBuilder, TarEntryOffset)
initBuilder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Absolute -> IO (Either (Maybe IOException) TarIndex)
tryReadIndex (Cache -> Path Absolute
cachedIndexIdxPath Cache
cache)
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile (forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatUn
FUn) IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hTar -> do
Handle -> TarEntryOffset -> IO ()
TarIndex.hSeekEntryOffset Handle
hTar TarEntryOffset
offset
Entries FormatError
newEntries <- ByteString -> Entries FormatError
Tar.read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BS.L.hGetContents Handle
hTar
case forall e. IndexBuilder -> Entries e -> Either e TarIndex
addEntries IndexBuilder
builder Entries FormatError
newEntries of
Left FormatError
ex -> forall e a. Exception e => e -> IO a
throwUnchecked FormatError
ex
Right TarIndex
idx -> forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile (Cache -> Path Absolute
cachedIndexIdxPath Cache
cache) IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
hIdx -> do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
hIdx (Maybe Int -> BufferMode
BlockBuffering forall a. Maybe a
Nothing)
Handle -> ByteString -> IO ()
BS.hPut Handle
hIdx forall a b. (a -> b) -> a -> b
$ TarIndex -> ByteString
TarIndex.serialise TarIndex
idx
where
initBuilder :: Either e TarIndex -> (IndexBuilder, TarEntryOffset)
initBuilder :: forall e. Either e TarIndex -> (IndexBuilder, TarEntryOffset)
initBuilder (Left e
_) = ( IndexBuilder
TarIndex.empty, TarEntryOffset
0 )
initBuilder (Right TarIndex
idx) = ( TarIndex -> IndexBuilder
TarIndex.unfinalise TarIndex
idx
, TarIndex -> TarEntryOffset
TarIndex.indexEndEntryOffset TarIndex
idx
)
getCached :: Cache -> CachedFile -> IO (Maybe (Path Absolute))
getCached :: Cache -> CachedFile -> IO (Maybe (Path Absolute))
getCached Cache
cache CachedFile
cachedFile = do
Bool
exists <- forall root. FsRoot root => Path root -> IO Bool
doesFileExist Path Absolute
localPath
if Bool
exists then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Absolute
localPath
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
where
localPath :: Path Absolute
localPath = Cache -> CachedFile -> Path Absolute
cachedFilePath Cache
cache CachedFile
cachedFile
getCachedIndex :: Cache -> Format f -> IO (Maybe (Path Absolute))
getCachedIndex :: forall f. Cache -> Format f -> IO (Maybe (Path Absolute))
getCachedIndex Cache
cache Format f
format = do
Bool
exists <- forall root. FsRoot root => Path root -> IO Bool
doesFileExist Path Absolute
localPath
if Bool
exists then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Absolute
localPath
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
where
localPath :: Path Absolute
localPath = forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format f
format
getCachedRoot :: Cache -> IO (Path Absolute)
getCachedRoot :: Cache -> IO (Path Absolute)
getCachedRoot Cache
cache = do
Maybe (Path Absolute)
mPath <- Cache -> CachedFile -> IO (Maybe (Path Absolute))
getCached Cache
cache CachedFile
CachedRoot
case Maybe (Path Absolute)
mPath of
Just Path Absolute
p -> forall (m :: * -> *) a. Monad m => a -> m a
return Path Absolute
p
Maybe (Path Absolute)
Nothing -> forall a. [Char] -> IO a
internalError [Char]
"Client missing root info"
getIndexIdx :: Cache -> IO TarIndex
getIndexIdx :: Cache -> IO TarIndex
getIndexIdx Cache
cache = do
Either (Maybe IOException) TarIndex
mIndex <- Path Absolute -> IO (Either (Maybe IOException) TarIndex)
tryReadIndex forall a b. (a -> b) -> a -> b
$ Cache -> Path Absolute
cachedIndexIdxPath Cache
cache
case Either (Maybe IOException) TarIndex
mIndex of
Left Maybe IOException
_ -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError [Char]
"Could not read index. Did you call 'checkForUpdates'?"
Right TarIndex
idx -> forall (m :: * -> *) a. Monad m => a -> m a
return TarIndex
idx
withIndex :: Cache -> (Handle -> IO a) -> IO a
withIndex :: forall a. Cache -> (Handle -> IO a) -> IO a
withIndex Cache
cache = forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile (forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatUn
FUn) IOMode
ReadMode
clearCache :: Cache -> IO ()
clearCache :: Cache -> IO ()
clearCache Cache
cache = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Maybe a)
handleDoesNotExist forall a b. (a -> b) -> a -> b
$ do
forall root. FsRoot root => Path root -> IO ()
removeFile forall a b. (a -> b) -> a -> b
$ Cache -> CachedFile -> Path Absolute
cachedFilePath Cache
cache CachedFile
CachedTimestamp
forall root. FsRoot root => Path root -> IO ()
removeFile forall a b. (a -> b) -> a -> b
$ Cache -> CachedFile -> Path Absolute
cachedFilePath Cache
cache CachedFile
CachedSnapshot
lockCache :: Cache -> IO () -> IO ()
lockCache :: Cache -> IO () -> IO ()
lockCache Cache{Path Absolute
CacheLayout
cacheLayout :: CacheLayout
cacheRoot :: Path Absolute
cacheLayout :: Cache -> CacheLayout
cacheRoot :: Cache -> Path Absolute
..} = forall a.
(WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a
withDirLock (\WithDirLockEvent
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) Path Absolute
cacheRoot
lockCacheWithLogger :: (LogMessage -> IO ()) -> Cache -> IO () -> IO ()
lockCacheWithLogger :: (LogMessage -> IO ()) -> Cache -> IO () -> IO ()
lockCacheWithLogger LogMessage -> IO ()
logger Cache{Path Absolute
CacheLayout
cacheLayout :: CacheLayout
cacheRoot :: Path Absolute
cacheLayout :: Cache -> CacheLayout
cacheRoot :: Cache -> Path Absolute
..} = forall a.
(WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a
withDirLock WithDirLockEvent -> IO ()
logger' Path Absolute
cacheRoot
where
logger' :: WithDirLockEvent -> IO ()
logger' (WithDirLockEventPre Path Absolute
fn) = LogMessage -> IO ()
logger (Path Absolute -> LogMessage
LogLockWait Path Absolute
fn)
logger' (WithDirLockEventPost Path Absolute
fn) = LogMessage -> IO ()
logger (Path Absolute -> LogMessage
LogLockWaitDone Path Absolute
fn)
logger' (WithDirLockEventUnlock Path Absolute
fn) = LogMessage -> IO ()
logger (Path Absolute -> LogMessage
LogUnlock Path Absolute
fn)
addEntries :: IndexBuilder -> Entries e -> Either e TarIndex
addEntries :: forall e. IndexBuilder -> Entries e -> Either e TarIndex
addEntries = forall e. IndexBuilder -> Entries e -> Either e TarIndex
go
where
go :: IndexBuilder -> Entries a -> Either a TarIndex
go !IndexBuilder
builder (Next Entry
e Entries a
es) = IndexBuilder -> Entries a -> Either a TarIndex
go (Entry -> IndexBuilder -> IndexBuilder
TarIndex.addNextEntry Entry
e IndexBuilder
builder) Entries a
es
go !IndexBuilder
builder Entries a
Done = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! IndexBuilder -> TarIndex
TarIndex.finalise IndexBuilder
builder
go !IndexBuilder
_ (Fail a
err) = forall a b. a -> Either a b
Left a
err
tryReadIndex :: Path Absolute -> IO (Either (Maybe IOException) TarIndex)
tryReadIndex :: Path Absolute -> IO (Either (Maybe IOException) TarIndex)
tryReadIndex Path Absolute
fp =
forall e a leftover.
Either e (Maybe (a, leftover)) -> Either (Maybe e) a
aux forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> IO (Either e a)
try (ByteString -> Maybe (TarIndex, ByteString)
TarIndex.deserialise forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall root. FsRoot root => Path root -> IO ByteString
readStrictByteString Path Absolute
fp)
where
aux :: Either e (Maybe (a, leftover)) -> Either (Maybe e) a
aux :: forall e a leftover.
Either e (Maybe (a, leftover)) -> Either (Maybe e) a
aux (Left e
e) = forall a b. a -> Either a b
Left (forall a. a -> Maybe a
Just e
e)
aux (Right Maybe (a, leftover)
Nothing) = forall a b. a -> Either a b
Left forall a. Maybe a
Nothing
aux (Right (Just (a
a, leftover
_))) = forall a b. b -> Either a b
Right a
a
cachedFilePath :: Cache -> CachedFile -> Path Absolute
cachedFilePath :: Cache -> CachedFile -> Path Absolute
cachedFilePath Cache{cacheLayout :: Cache -> CacheLayout
cacheLayout=CacheLayout{CachePath
cacheLayoutIndexTarGz :: CacheLayout -> CachePath
cacheLayoutIndexIdx :: CacheLayout -> CachePath
cacheLayoutIndexTar :: CacheLayout -> CachePath
cacheLayoutMirrors :: CacheLayout -> CachePath
cacheLayoutSnapshot :: CacheLayout -> CachePath
cacheLayoutTimestamp :: CacheLayout -> CachePath
cacheLayoutRoot :: CacheLayout -> CachePath
cacheLayoutIndexTarGz :: CachePath
cacheLayoutIndexIdx :: CachePath
cacheLayoutIndexTar :: CachePath
cacheLayoutMirrors :: CachePath
cacheLayoutSnapshot :: CachePath
cacheLayoutTimestamp :: CachePath
cacheLayoutRoot :: CachePath
..}, Path Absolute
cacheRoot :: Path Absolute
cacheRoot :: Cache -> Path Absolute
..} CachedFile
file =
forall root. Path root -> CachePath -> Path root
anchorCachePath Path Absolute
cacheRoot forall a b. (a -> b) -> a -> b
$ CachedFile -> CachePath
go CachedFile
file
where
go :: CachedFile -> CachePath
go :: CachedFile -> CachePath
go CachedFile
CachedRoot = CachePath
cacheLayoutRoot
go CachedFile
CachedTimestamp = CachePath
cacheLayoutTimestamp
go CachedFile
CachedSnapshot = CachePath
cacheLayoutSnapshot
go CachedFile
CachedMirrors = CachePath
cacheLayoutMirrors
cachedIndexPath :: Cache -> Format f -> Path Absolute
cachedIndexPath :: forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache{Path Absolute
CacheLayout
cacheLayout :: CacheLayout
cacheRoot :: Path Absolute
cacheLayout :: Cache -> CacheLayout
cacheRoot :: Cache -> Path Absolute
..} Format f
format =
forall root. Path root -> CachePath -> Path root
anchorCachePath Path Absolute
cacheRoot forall a b. (a -> b) -> a -> b
$ forall f. Format f -> CachePath
go Format f
format
where
go :: Format f -> CachePath
go :: forall f. Format f -> CachePath
go Format f
FUn = CacheLayout -> CachePath
cacheLayoutIndexTar CacheLayout
cacheLayout
go Format f
FGz = CacheLayout -> CachePath
cacheLayoutIndexTarGz CacheLayout
cacheLayout
cachedIndexIdxPath :: Cache -> Path Absolute
cachedIndexIdxPath :: Cache -> Path Absolute
cachedIndexIdxPath Cache{Path Absolute
CacheLayout
cacheLayout :: CacheLayout
cacheRoot :: Path Absolute
cacheLayout :: Cache -> CacheLayout
cacheRoot :: Cache -> Path Absolute
..} =
forall root. Path root -> CachePath -> Path root
anchorCachePath Path Absolute
cacheRoot forall a b. (a -> b) -> a -> b
$ CacheLayout -> CachePath
cacheLayoutIndexIdx CacheLayout
cacheLayout