{-# LANGUAGE BangPatterns #-}
-- | The files we cache from the repository
--
-- Both the Local and the Remote repositories make use of this module.
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

-- | Location and layout of the local cache
data Cache = Cache {
      Cache -> Path Absolute
cacheRoot   :: Path Absolute
    , Cache -> CacheLayout
cacheLayout :: CacheLayout
    }

-- | Cache a previously downloaded remote file
cacheRemoteFile :: forall down typ f. DownloadedFile down
                => Cache -> down typ -> Format f -> IsCached typ -> IO ()
cacheRemoteFile :: 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 -> () -> IO ()
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      = () -> IO ()
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 (Cache -> Format FormatGz -> Path Absolute
forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatGz
FGz) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
unzipIndex
    go Format f
_ IsCached typ
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"cacheRemoteFile: unexpected case" -- TODO: enforce in types?

    copyTo :: Path Absolute -> IO ()
    copyTo :: Path Absolute -> IO ()
copyTo Path Absolute
fp = do
      Bool -> Path Absolute -> IO ()
forall root. FsRoot root => Bool -> Path root -> IO ()
createDirectoryIfMissing Bool
True (Path Absolute -> Path Absolute
forall a. Path a -> Path a
takeDirectory Path Absolute
fp)
      down typ -> Path Absolute -> IO ()
forall (down :: * -> *) a.
DownloadedFile down =>
down a -> Path Absolute -> IO ()
downloadedCopyTo down typ
downloaded Path Absolute
fp

    -- Whether or not we downloaded the compressed index incrementally, we can
    -- update the uncompressed index incrementally (assuming the local files
    -- have not been corrupted).
    -- NOTE: This assumes we already updated the compressed file.
    unzipIndex :: IO ()
    unzipIndex :: IO ()
unzipIndex = do
        Bool -> Path Absolute -> IO ()
forall root. FsRoot root => Bool -> Path root -> IO ()
createDirectoryIfMissing Bool
True (Path Absolute -> Path Absolute
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success IO ()
unzipNonIncremental
          else IO ()
unzipNonIncremental
      where
        unzipIncremental :: IO Bool
unzipIncremental = do
          ByteString
compressed <- Path Absolute -> IO ByteString
forall root. FsRoot root => Path root -> IO ByteString
readLazyByteString Path Absolute
indexGz
          let uncompressed :: ByteString
uncompressed = ByteString -> ByteString
GZip.decompress ByteString
compressed

          -- compare prefix of old index with prefix of new index to
          -- ensure that it's safe to incrementally append
          (Integer
seekTo',ByteString
newTail') <- Path Absolute
-> IOMode
-> (Handle -> IO (Integer, ByteString))
-> IO (Integer, ByteString)
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
indexUn IOMode
ReadMode ((Handle -> IO (Integer, ByteString)) -> IO (Integer, ByteString))
-> (Handle -> IO (Integer, ByteString)) -> IO (Integer, ByteString)
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
                                ExceptT (Integer, ByteString) IO (Integer, ByteString)
-> IO (Integer, ByteString)
forall (m :: * -> *) a. Monad m => ExceptT a m a -> m a
multipleExitPoints (ExceptT (Integer, ByteString) IO (Integer, ByteString)
 -> IO (Integer, ByteString))
-> ExceptT (Integer, ByteString) IO (Integer, ByteString)
-> IO (Integer, ByteString)
forall a b. (a -> b) -> a -> b
$ do
            Integer
currentSize <- IO Integer -> ExceptT (Integer, ByteString) IO Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> ExceptT (Integer, ByteString) IO Integer)
-> IO Integer -> ExceptT (Integer, ByteString) IO Integer
forall a b. (a -> b) -> a -> b
$ Handle -> IO Integer
hFileSize Handle
h
            let seekTo :: Integer
seekTo = Integer
0 Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
`max` (Integer
currentSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
tarTrailer)
                (ByteString
newPrefix,ByteString
newTail) = Int64 -> ByteString -> (ByteString, ByteString)
BS.L.splitAt (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
seekTo)
                                      ByteString
uncompressed

            (ByteString
oldPrefix,ByteString
oldTrailer) <- Int64 -> ByteString -> (ByteString, ByteString)
BS.L.splitAt (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
seekTo) (ByteString -> (ByteString, ByteString))
-> ExceptT (Integer, ByteString) IO ByteString
-> ExceptT (Integer, ByteString) IO (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                      IO ByteString -> ExceptT (Integer, ByteString) IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ByteString
BS.L.hGetContents Handle
h)

            Bool
-> ExceptT (Integer, ByteString) IO ()
-> ExceptT (Integer, ByteString) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
oldPrefix ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
newPrefix) (ExceptT (Integer, ByteString) IO ()
 -> ExceptT (Integer, ByteString) IO ())
-> ExceptT (Integer, ByteString) IO ()
-> ExceptT (Integer, ByteString) IO ()
forall a b. (a -> b) -> a -> b
$
              (Integer, ByteString) -> ExceptT (Integer, ByteString) IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (Integer
0,ByteString
forall a. Monoid a => a
mempty) -- corrupted index.tar prefix

            -- sanity check: verify there's a 1KiB zero-filled trailer
            Bool
-> ExceptT (Integer, ByteString) IO ()
-> ExceptT (Integer, ByteString) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
oldTrailer ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
tarTrailerBs) (ExceptT (Integer, ByteString) IO ()
 -> ExceptT (Integer, ByteString) IO ())
-> ExceptT (Integer, ByteString) IO ()
-> ExceptT (Integer, ByteString) IO ()
forall a b. (a -> b) -> a -> b
$
              (Integer, ByteString) -> ExceptT (Integer, ByteString) IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (Integer
0,ByteString
forall a. Monoid a => a
mempty) -- corrupted .tar trailer

            (Integer, ByteString)
-> ExceptT (Integer, ByteString) IO (Integer, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
seekTo,ByteString
newTail)

          if Integer
seekTo' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
          then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- fallback to non-incremental update
          else Path Absolute -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
indexUn IOMode
ReadWriteMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
            -- everything seems fine; append the new data
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
seekTo'
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.L.hPut Handle
h ByteString
newTail'
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

        unzipNonIncremental :: IO ()
unzipNonIncremental = do
          ByteString
compressed <- Path Absolute -> IO ByteString
forall root. FsRoot root => Path root -> IO ByteString
readLazyByteString Path Absolute
indexGz
          let uncompressed :: ByteString
uncompressed = ByteString -> ByteString
GZip.decompress ByteString
compressed
          Path Absolute -> IOMode -> (Handle -> IO ()) -> IO ()
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
indexUn IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
            Handle -> ByteString -> IO ()
BS.L.hPut Handle
h ByteString
uncompressed
          IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ())
-> (IO () -> IO (Maybe ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Maybe ())
forall a. IO a -> IO (Maybe a)
handleDoesNotExist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
removeFile Path Absolute
indexIdx -- Force a full rebuild of the index too

        -- When we update the 00-index.tar we also update the 00-index.tar.idx
        -- so the expected state is that the modification time for the tar.idx
        -- is the same or later than the .tar file. But if someone modified
        -- the 00-index.tar then the modification times will be reversed. So,
        -- if the modification times are reversed then we should not do an
        -- incremental update but should rewrite the whole file.
        cachedIndexProbablyValid :: IO Bool
        cachedIndexProbablyValid :: IO Bool
cachedIndexProbablyValid =
          (Maybe Bool -> Bool) -> IO (Maybe Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (IO (Maybe Bool) -> IO Bool) -> IO (Maybe Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$
          IO Bool -> IO (Maybe Bool)
forall a. IO a -> IO (Maybe a)
handleDoesNotExist (IO Bool -> IO (Maybe Bool)) -> IO Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ do
            UTCTime
tsUn  <- Path Absolute -> IO UTCTime
forall root. FsRoot root => Path root -> IO UTCTime
getModificationTime Path Absolute
indexUn
            UTCTime
tsIdx <- Path Absolute -> IO UTCTime
forall root. FsRoot root => Path root -> IO UTCTime
getModificationTime Path Absolute
indexIdx
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
tsIdx UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
tsUn)

        indexGz :: Path Absolute
indexGz  = Cache -> Format FormatGz -> Path Absolute
forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatGz
FGz
        indexUn :: Path Absolute
indexUn  = Cache -> Format FormatUn -> Path Absolute
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 (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
tarTrailer) Word8
0x00

-- | Rebuild the tarball index
--
-- Attempts to add to the existing index, if one exists.
--
-- TODO: Use throwChecked rather than throwUnchecked, and deal with the fallout.
-- See <https://github.com/well-typed/hackage-security/issues/84>.
rebuildTarIndex :: Cache -> IO ()
rebuildTarIndex :: Cache -> IO ()
rebuildTarIndex Cache
cache = do
    (IndexBuilder
builder, TarEntryOffset
offset) <- Either (Maybe IOException) TarIndex
-> (IndexBuilder, TarEntryOffset)
forall e. Either e TarIndex -> (IndexBuilder, TarEntryOffset)
initBuilder (Either (Maybe IOException) TarIndex
 -> (IndexBuilder, TarEntryOffset))
-> IO (Either (Maybe IOException) TarIndex)
-> IO (IndexBuilder, TarEntryOffset)
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)
    Path Absolute -> IOMode -> (Handle -> IO ()) -> IO ()
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile (Cache -> Format FormatUn -> Path Absolute
forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatUn
FUn) IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
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 (ByteString -> Entries FormatError)
-> IO ByteString -> IO (Entries FormatError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BS.L.hGetContents Handle
hTar
      case IndexBuilder -> Entries FormatError -> Either FormatError TarIndex
forall e. IndexBuilder -> Entries e -> Either e TarIndex
addEntries IndexBuilder
builder Entries FormatError
newEntries of
        Left  FormatError
ex  -> FormatError -> IO ()
forall e a. Exception e => e -> IO a
throwUnchecked FormatError
ex
        Right TarIndex
idx -> Path Absolute -> IOMode -> (Handle -> IO ()) -> IO ()
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile (Cache -> Path Absolute
cachedIndexIdxPath Cache
cache) IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
hIdx -> do
                       Handle -> BufferMode -> IO ()
hSetBuffering Handle
hIdx (Maybe Int -> BufferMode
BlockBuffering Maybe Int
forall a. Maybe a
Nothing)
                       Handle -> ByteString -> IO ()
BS.hPut Handle
hIdx (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ TarIndex -> ByteString
TarIndex.serialise TarIndex
idx
  where
    -- The initial index builder
    -- If we don't have an index (or it's broken), we start from scratch
    initBuilder :: Either e TarIndex -> (IndexBuilder, TarEntryOffset)
    initBuilder :: 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
                              )

-- | Get a cached file (if available)
getCached :: Cache -> CachedFile -> IO (Maybe (Path Absolute))
getCached :: Cache -> CachedFile -> IO (Maybe (Path Absolute))
getCached Cache
cache CachedFile
cachedFile = do
    Bool
exists <- Path Absolute -> IO Bool
forall root. FsRoot root => Path root -> IO Bool
doesFileExist Path Absolute
localPath
    if Bool
exists then Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path Absolute) -> IO (Maybe (Path Absolute)))
-> Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall a b. (a -> b) -> a -> b
$ Path Absolute -> Maybe (Path Absolute)
forall a. a -> Maybe a
Just Path Absolute
localPath
              else Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path Absolute) -> IO (Maybe (Path Absolute)))
-> Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall a b. (a -> b) -> a -> b
$ Maybe (Path Absolute)
forall a. Maybe a
Nothing
  where
    localPath :: Path Absolute
localPath = Cache -> CachedFile -> Path Absolute
cachedFilePath Cache
cache CachedFile
cachedFile

-- | Get the cached index (if available)
getCachedIndex :: Cache -> Format f -> IO (Maybe (Path Absolute))
getCachedIndex :: Cache -> Format f -> IO (Maybe (Path Absolute))
getCachedIndex Cache
cache Format f
format = do
    Bool
exists <- Path Absolute -> IO Bool
forall root. FsRoot root => Path root -> IO Bool
doesFileExist Path Absolute
localPath
    if Bool
exists then Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path Absolute) -> IO (Maybe (Path Absolute)))
-> Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall a b. (a -> b) -> a -> b
$ Path Absolute -> Maybe (Path Absolute)
forall a. a -> Maybe a
Just Path Absolute
localPath
              else Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path Absolute) -> IO (Maybe (Path Absolute)))
-> Maybe (Path Absolute) -> IO (Maybe (Path Absolute))
forall a b. (a -> b) -> a -> b
$ Maybe (Path Absolute)
forall a. Maybe a
Nothing
  where
    localPath :: Path Absolute
localPath = Cache -> Format f -> Path Absolute
forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format f
format

-- | Get the cached root
--
-- Calling 'getCachedRoot' without root info available is a programmer error
-- and will result in an unchecked exception. See 'requiresBootstrap'.
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  -> Path Absolute -> IO (Path Absolute)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Absolute
p
      Maybe (Path Absolute)
Nothing -> [Char] -> IO (Path Absolute)
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 (Path Absolute -> IO (Either (Maybe IOException) TarIndex))
-> Path Absolute -> IO (Either (Maybe IOException) TarIndex)
forall a b. (a -> b) -> a -> b
$ Cache -> Path Absolute
cachedIndexIdxPath Cache
cache
    case Either (Maybe IOException) TarIndex
mIndex of
      Left  Maybe IOException
_   -> IOException -> IO TarIndex
forall e a. Exception e => e -> IO a
throwIO (IOException -> IO TarIndex) -> IOException -> IO TarIndex
forall a b. (a -> b) -> a -> b
$ [Char] -> IOException
userError [Char]
"Could not read index. Did you call 'checkForUpdates'?"
      Right TarIndex
idx -> TarIndex -> IO TarIndex
forall (m :: * -> *) a. Monad m => a -> m a
return TarIndex
idx

withIndex :: Cache -> (Handle -> IO a) -> IO a
withIndex :: Cache -> (Handle -> IO a) -> IO a
withIndex Cache
cache = Path Absolute -> IOMode -> (Handle -> IO a) -> IO a
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile (Cache -> Format FormatUn -> Path Absolute
forall f. Cache -> Format f -> Path Absolute
cachedIndexPath Cache
cache Format FormatUn
FUn) IOMode
ReadMode

-- | Delete a previously downloaded remote file
clearCache :: Cache -> IO ()
clearCache :: Cache -> IO ()
clearCache Cache
cache = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ())
-> (IO () -> IO (Maybe ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Maybe ())
forall a. IO a -> IO (Maybe a)
handleDoesNotExist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
removeFile (Path Absolute -> IO ()) -> Path Absolute -> IO ()
forall a b. (a -> b) -> a -> b
$ Cache -> CachedFile -> Path Absolute
cachedFilePath Cache
cache CachedFile
CachedTimestamp
    Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
removeFile (Path Absolute -> IO ()) -> Path Absolute -> IO ()
forall a b. (a -> b) -> a -> b
$ Cache -> CachedFile -> Path Absolute
cachedFilePath Cache
cache CachedFile
CachedSnapshot

-- | Lock the cache
--
-- This avoids two concurrent processes updating the cache at the same time,
-- provided they both take the lock.
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
..} = (WithDirLockEvent -> IO ()) -> Path Absolute -> IO () -> IO ()
forall a.
(WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a
withDirLock (\WithDirLockEvent
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Path Absolute
cacheRoot

-- | Variant of 'lockCache' which emits 'LogMessage's before and after
-- a possibly blocking file-locking system call
--
-- @since 0.6.0
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
..} = (WithDirLockEvent -> IO ()) -> Path Absolute -> IO () -> IO ()
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)

{-------------------------------------------------------------------------------
  Auxiliary: tar
-------------------------------------------------------------------------------}

-- | Variation on 'TarIndex.build' that takes in the initial 'IndexBuilder'
addEntries :: IndexBuilder -> Entries e -> Either e TarIndex
addEntries :: IndexBuilder -> Entries e -> Either e TarIndex
addEntries = IndexBuilder -> Entries e -> Either e TarIndex
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       = TarIndex -> Either a TarIndex
forall a b. b -> Either a b
Right (TarIndex -> Either a TarIndex) -> TarIndex -> Either a TarIndex
forall a b. (a -> b) -> a -> b
$! IndexBuilder -> TarIndex
TarIndex.finalise IndexBuilder
builder
    go !IndexBuilder
_       (Fail a
err)  = a -> Either a TarIndex
forall a b. a -> Either a b
Left a
err

-- TODO: How come 'deserialise' uses _strict_ ByteStrings?
tryReadIndex :: Path Absolute -> IO (Either (Maybe IOException) TarIndex)
tryReadIndex :: Path Absolute -> IO (Either (Maybe IOException) TarIndex)
tryReadIndex Path Absolute
fp =
    Either IOException (Maybe (TarIndex, ByteString))
-> Either (Maybe IOException) TarIndex
forall e a leftover.
Either e (Maybe (a, leftover)) -> Either (Maybe e) a
aux (Either IOException (Maybe (TarIndex, ByteString))
 -> Either (Maybe IOException) TarIndex)
-> IO (Either IOException (Maybe (TarIndex, ByteString)))
-> IO (Either (Maybe IOException) TarIndex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (TarIndex, ByteString))
-> IO (Either IOException (Maybe (TarIndex, ByteString)))
forall e a. Exception e => IO a -> IO (Either e a)
try (ByteString -> Maybe (TarIndex, ByteString)
TarIndex.deserialise (ByteString -> Maybe (TarIndex, ByteString))
-> IO ByteString -> IO (Maybe (TarIndex, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Absolute -> IO ByteString
forall root. FsRoot root => Path root -> IO ByteString
readStrictByteString Path Absolute
fp)
  where
    aux :: Either e (Maybe (a, leftover)) -> Either (Maybe e) a
    aux :: Either e (Maybe (a, leftover)) -> Either (Maybe e) a
aux (Left e
e)              = Maybe e -> Either (Maybe e) a
forall a b. a -> Either a b
Left (e -> Maybe e
forall a. a -> Maybe a
Just e
e)
    aux (Right Maybe (a, leftover)
Nothing)       = Maybe e -> Either (Maybe e) a
forall a b. a -> Either a b
Left Maybe e
forall a. Maybe a
Nothing
    aux (Right (Just (a
a, leftover
_))) = a -> Either (Maybe e) a
forall a b. b -> Either a b
Right a
a

{-------------------------------------------------------------------------------
  Auxiliary: paths
-------------------------------------------------------------------------------}

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 =
    Path Absolute -> CachePath -> Path Absolute
forall root. Path root -> CachePath -> Path root
anchorCachePath Path Absolute
cacheRoot (CachePath -> Path Absolute) -> CachePath -> Path Absolute
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 :: 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 =
    Path Absolute -> CachePath -> Path Absolute
forall root. Path root -> CachePath -> Path root
anchorCachePath Path Absolute
cacheRoot (CachePath -> Path Absolute) -> CachePath -> Path Absolute
forall a b. (a -> b) -> a -> b
$ Format f -> CachePath
forall f. Format f -> CachePath
go Format f
format
  where
    go :: Format f -> CachePath
    go :: 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
..} =
    Path Absolute -> CachePath -> Path Absolute
forall root. Path root -> CachePath -> Path root
anchorCachePath Path Absolute
cacheRoot (CachePath -> Path Absolute) -> CachePath -> Path Absolute
forall a b. (a -> b) -> a -> b
$ CacheLayout -> CachePath
cacheLayoutIndexIdx CacheLayout
cacheLayout