{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.PackageIndex
( updateAllIndices
, getPackageCaches
, getPackageVersions
, lookupPackageVersions
, CabalLoader (..)
, HasCabalLoader (..)
, configPackageIndex
, configPackageIndexRoot
) where
import qualified Codec.Archive.Tar as Tar
import Stack.Prelude
import Data.Aeson.Extended
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L
import Data.Conduit.Zlib (ungzip)
import qualified Data.List.NonEmpty as NE
import qualified Data.HashMap.Strict as HashMap
import Data.Store.Version
import Data.Store.VersionTagged
import qualified Data.Text as T
import Data.Text.Unsafe (unsafeTail)
import Data.Time (getCurrentTime)
import qualified Hackage.Security.Client as HS
import qualified Hackage.Security.Client.Repository.Cache as HS
import qualified Hackage.Security.Client.Repository.Remote as HS
import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS
import qualified Hackage.Security.Util.Path as HS
import qualified Hackage.Security.Util.Pretty as HS
import Network.HTTP.StackClient (getGlobalManager)
import Network.HTTP.Download
import Network.URI (parseURI)
import Path (toFilePath, parseAbsFile, mkRelDir, mkRelFile, (</>), parseRelDir)
import Path.Extra (tryGetModificationTime)
import Path.IO
import Stack.Types.PackageIdentifier
import Stack.Types.PackageIndex
import Stack.Types.PackageName
import Stack.Types.Runner (HasRunner)
import Stack.Types.Version
import qualified System.Directory as D
import System.FilePath ((<.>))
populateCache :: HasCabalLoader env => PackageIndex -> RIO env (PackageCache ())
populateCache index = do
requireIndex index
path <- configPackageIndex (indexName index)
let loadPIS = withLazyFile (Path.toFilePath path) $ \lbs -> do
logSticky "Populating index cache ..."
loop 0 HashMap.empty (Tar.read lbs)
pis0 <- loadPIS `catch` \e -> do
logWarn $ "Exception encountered when parsing index tarball: "
<> displayShow (e :: Tar.FormatError)
logWarn "Automatically updating index and trying again"
updateIndex index
loadPIS
when (indexRequireHashes index) $ forM_ (HashMap.toList pis0) $ \(ident, (mpd, _)) ->
case mpd :: Maybe PackageDownload of
Just _ -> return ()
Nothing -> throwM $ MissingRequiredHashes (indexName index) ident
cache <- fmap mconcat $ mapM convertPI $ HashMap.toList pis0
logStickyDone "Populated index cache."
return cache
where
convertPI :: MonadIO m
=> (PackageIdentifier, (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]))
-> m (PackageCache ())
convertPI (ident@(PackageIdentifier name version), (mpd, Endo front)) =
case NE.nonEmpty $ front [] of
Nothing -> throwString $ "Missing cabal file info for: " ++ show ident
Just files -> return
$ PackageCache
$ HashMap.singleton name
$ HashMap.singleton version
((), mpd, files)
loop :: MonadThrow m
=> Int64
-> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])
-> Tar.Entries Tar.FormatError
-> m (HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]))
loop !blockNo !m (Tar.Next e es) =
loop (blockNo + entrySizeInBlocks e) (goE blockNo m e) es
loop _ m Tar.Done = return m
loop _ _ (Tar.Fail e) = throwM e
goE :: Int64
-> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])
-> Tar.Entry
-> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])
goE blockNo m e =
case Tar.entryContent e of
Tar.NormalFile lbs size ->
case parseNameVersionSuffix $ Tar.entryPath e of
Just (ident, ".cabal") -> addCabal lbs ident size
Just (ident, ".json") -> addJSON id ident lbs
_ ->
case parsePackageJSON $ Tar.entryPath e of
Just ident -> addJSON unHSPackageDownload ident lbs
Nothing -> m
_ -> m
where
addCabal lbs ident size = HashMap.alter
(\case
Nothing -> Just (Nothing, newEndo)
Just (mpd, oldEndo) -> Just (mpd, oldEndo <> newEndo))
ident
m
where
!cabalHash = computeCabalHash lbs
cr = 13
cabalHashes
| cr `L.elem` lbs =
let !cabalHash' = computeCabalHash (L.filter (/= cr) lbs)
in [cabalHash, cabalHash']
| otherwise = [cabalHash]
offsetSize = OffsetSize ((blockNo + 1) * 512) size
newPair = (cabalHashes, offsetSize)
newEndo = Endo (newPair:)
addJSON :: FromJSON a
=> (a -> PackageDownload)
-> PackageIdentifier
-> L.ByteString
-> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])
addJSON unwrap ident lbs =
case decode lbs of
Nothing -> m
Just (unwrap -> pd) -> HashMap.alter
(\case
Nothing -> Just (Just pd, mempty)
Just (Just oldPD, _)
| oldPD /= pd -> error $ concat
[ "Conflicting package hash information discovered for "
, packageIdentifierString ident
, "\nFound both: \n- "
, show oldPD
, "\n- "
, show pd
, "\n\nThis should not happen. See: https://github.com/haskell/hackage-security/issues/189"
]
Just (_, files) -> Just (Just pd, files))
ident
m
breakSlash x
| T.null z = Nothing
| otherwise = Just (y, unsafeTail z)
where
(y, z) = T.break (== '/') x
parseNameVersion t1 = do
(p', t3) <- breakSlash
$ T.map (\c -> if c == '\\' then '/' else c)
$ T.pack t1
p <- parsePackageName p'
(v', t5) <- breakSlash t3
v <- parseVersion v'
return (p', p, v, t5)
parseNameVersionSuffix t1 = do
(p', p, v, t5) <- parseNameVersion t1
let (t6, suffix) = T.break (== '.') t5
guard $ t6 == p'
return (PackageIdentifier p v, suffix)
parsePackageJSON t1 = do
(_, p, v, t5) <- parseNameVersion t1
guard $ t5 == "package.json"
return $ PackageIdentifier p v
data PackageIndexException
= GitNotAvailable IndexName
| MissingRequiredHashes IndexName PackageIdentifier
deriving Typeable
instance Exception PackageIndexException
instance Show PackageIndexException where
show (GitNotAvailable name) = concat
[ "Package index "
, T.unpack $ indexNameText name
, " only provides Git access, and you do not have"
, " the git executable on your PATH"
]
show (MissingRequiredHashes name ident) = concat
[ "Package index "
, T.unpack $ indexNameText name
, " is configured to require package hashes, but no"
, " hash is available for "
, packageIdentifierString ident
]
requireIndex :: HasCabalLoader env => PackageIndex -> RIO env ()
requireIndex index = do
tarFile <- configPackageIndex $ indexName index
exists <- doesFileExist tarFile
unless exists $ updateIndex index
updateAllIndices :: HasCabalLoader env => RIO env ()
updateAllIndices = do
clearPackageCaches
cl <- view cabalLoaderL
mapM_ updateIndex (clIndices cl)
updateIndex :: HasCabalLoader env => PackageIndex -> RIO env ()
updateIndex index =
do let name = indexName index
url = indexLocation index
logSticky $ "Updating package index "
<> display (indexNameText (indexName index))
<> " (mirrored at "
<> display url
<> ") ..."
case indexType index of
ITVanilla -> updateIndexHTTP name url
ITHackageSecurity hs -> updateIndexHackageSecurity name url hs
logStickyDone "Update complete"
tarFile <- configPackageIndex name
oldTarFile <- configPackageIndexOld name
oldCacheFile <- configPackageIndexCacheOld name
liftIO $ ignoringAbsence (removeFile oldCacheFile)
withSourceFile (toFilePath tarFile) $ \src ->
withSinkFile (toFilePath oldTarFile) $ \sink ->
runConduit $ src .| sink
updateIndexHTTP :: HasCabalLoader env
=> IndexName
-> Text
-> RIO env ()
updateIndexHTTP indexName' url = do
req <- parseRequest $ T.unpack url
logInfo ("Downloading package index from " <> display url)
gz <- configPackageIndexGz indexName'
tar <- configPackageIndex indexName'
wasDownloaded <- redownload req gz
shouldUnpack <-
if wasDownloaded
then return True
else not `liftM` doesFileExist tar
if not shouldUnpack
then packageIndexNotUpdated indexName'
else do
let tmp = toFilePath tar <.> "tmp"
tmpPath <- parseAbsFile tmp
deleteCache indexName'
liftIO $ do
withSourceFile (toFilePath gz) $ \input ->
withSinkFile tmp $ \output ->
runConduit $ input .| ungzip .| output
renameFile tmpPath tar
updateIndexHackageSecurity
:: HasCabalLoader env
=> IndexName
-> Text
-> HackageSecurity
-> RIO env ()
updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = do
baseURI <-
case parseURI $ T.unpack url of
Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url
Just x -> return x
manager <- liftIO getGlobalManager
root <- configPackageIndexRoot indexName'
run <- askRunInIO
let logTUF = run . logInfo . fromString . HS.pretty
withRepo = HS.withRepository
(HS.makeHttpLib manager)
[baseURI]
HS.defaultRepoOpts
HS.Cache
{ HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root
, HS.cacheLayout = HS.cabalCacheLayout
{ HS.cacheLayoutIndexTar = HS.rootPath $ HS.fragment "01-index.tar-tmp"
}
}
HS.hackageRepoLayout
HS.hackageIndexLayout
logTUF
didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do
needBootstrap <- HS.requiresBootstrap repo
when needBootstrap $ do
HS.bootstrap
repo
(map (HS.KeyId . T.unpack) keyIds)
(HS.KeyThreshold (fromIntegral threshold))
now <- getCurrentTime
HS.checkForUpdates repo (Just now)
case didUpdate of
HS.NoUpdates -> packageIndexNotUpdated indexName'
HS.HasUpdates -> do
tar <- configPackageIndex indexName'
deleteCache indexName'
liftIO $ D.renameFile (toFilePath tar ++ "-tmp") (toFilePath tar)
logInfo "Updated package index downloaded"
packageIndexNotUpdated :: HasCabalLoader env => IndexName -> RIO env ()
packageIndexNotUpdated indexName' = do
mindexModTime <- tryGetModificationTime =<< configPackageIndex indexName'
mcacheModTime <- tryGetModificationTime =<< configPackageIndexCache indexName'
case (mindexModTime, mcacheModTime) of
(Right indexModTime, Right cacheModTime) | cacheModTime < indexModTime -> do
deleteCache indexName'
logInfo "No updates to your package index were found, but clearing the index cache as it is older than the index."
(Left _, _) -> do
deleteCache indexName'
logError "Error: No updates to your package index were found, but downloaded index is missing."
_ -> logInfo "No updates to your package index were found"
deleteCache :: HasCabalLoader env => IndexName -> RIO env ()
deleteCache indexName' = do
fp <- configPackageIndexCache indexName'
eres <- liftIO $ tryIO $ removeFile fp
case eres of
Left e -> logDebug $ "Could not delete cache: " <> displayShow e
Right () -> logDebug $ "Deleted index cache at " <> fromString (toFilePath fp)
getPackageVersions :: HasCabalLoader env => PackageName -> RIO env (HashMap Version (Maybe CabalHash))
getPackageVersions pkgName = lookupPackageVersions pkgName <$> getPackageCaches
lookupPackageVersions :: PackageName -> PackageCache index -> HashMap Version (Maybe CabalHash)
lookupPackageVersions pkgName (PackageCache m) =
maybe HashMap.empty (HashMap.map extractOrigRevHash) $ HashMap.lookup pkgName m
where
extractOrigRevHash (_,_, neRevHashesAndOffsets) =
listToMaybe $ fst (NE.last neRevHashesAndOffsets)
getPackageCaches :: HasCabalLoader env => RIO env (PackageCache PackageIndex)
getPackageCaches = do
cl <- view cabalLoaderL
mcached <- readIORef (clCache cl)
case mcached of
Just cached -> return cached
Nothing -> do
result <- liftM mconcat $ forM (clIndices cl) $ \index -> do
fp <- configPackageIndexCache (indexName index)
PackageCache pis <-
#if MIN_VERSION_template_haskell(2,14,0)
$(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "35_zXZ4b4CIWfrLXtjWteR4nb6o="
#elif MIN_VERSION_template_haskell(2,13,0)
$(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "LLL6OCcimOqRm3r0JmsSlLHcaLE="
#else
$(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "A607WaDwhg5VVvZTxNgU9g52DO8="
#endif
:: VersionConfig (PackageCache ())))
fp
(populateCache index)
return $ PackageCache ((fmap.fmap) (\((), mpd, files) -> (index, mpd, files)) pis)
liftIO $ writeIORef (clCache cl) (Just result)
return result
clearPackageCaches :: HasCabalLoader env => RIO env ()
clearPackageCaches = do
cl <- view cabalLoaderL
writeIORef (clCache cl) Nothing
class HasRunner env => HasCabalLoader env where
cabalLoaderL :: Lens' env CabalLoader
data CabalLoader = CabalLoader
{ clCache :: !(IORef (Maybe (PackageCache PackageIndex)))
, clIndices :: ![PackageIndex]
, clStackRoot :: !(Path Abs Dir)
, clUpdateRef :: !(MVar Bool)
, clConnectionCount :: !Int
, clIgnoreRevisionMismatch :: !Bool
}
configPackageIndexRoot :: HasCabalLoader env => IndexName -> RIO env (Path Abs Dir)
configPackageIndexRoot (IndexName name) = do
cl <- view cabalLoaderL
let root = clStackRoot cl
dir <- parseRelDir $ B8.unpack name
return (root </> $(mkRelDir "indices") </> dir)
configPackageIndex :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)
configPackageIndex name = (</> $(mkRelFile "01-index.tar")) <$> configPackageIndexRoot name
configPackageIndexCache :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)
configPackageIndexCache name = (</> $(mkRelFile "01-index.cache")) <$> configPackageIndexRoot name
configPackageIndexCacheOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)
configPackageIndexCacheOld = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot
configPackageIndexOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)
configPackageIndexOld = liftM (</> $(mkRelFile "00-index.tar")) . configPackageIndexRoot
configPackageIndexGz :: HasCabalLoader env => IndexName -> RIO env (Path Abs File)
configPackageIndexGz = liftM (</> $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot
entrySizeInBlocks :: Tar.Entry -> Int64
entrySizeInBlocks entry = 1 + case Tar.entryContent entry of
Tar.NormalFile _ size -> bytesToBlocks size
Tar.OtherEntryType _ _ size -> bytesToBlocks size
_ -> 0
where
bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)