{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.GlobalFlags (
GlobalFlags(..)
, defaultGlobalFlags
, RepoContext(..)
, withRepoContext
, withRepoContext'
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Types
( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey )
import Distribution.Simple.Setup
( Flag(..), fromFlag, flagToMaybe )
import Distribution.Utils.NubList
( NubList, fromNubList )
import Distribution.Client.HttpUtils
( HttpTransport, configureTransport )
import Distribution.Simple.Utils
( info, warn )
import Distribution.Client.IndexUtils.ActiveRepos
( ActiveRepos )
import Control.Concurrent
( MVar, newMVar, modifyMVar )
import System.FilePath
( (</>) )
import Network.URI
( URI, uriScheme, uriPath )
import qualified Data.Map as Map
import qualified Hackage.Security.Client as Sec
import qualified Hackage.Security.Util.Path as Sec
import qualified Hackage.Security.Util.Pretty as Sec
import qualified Hackage.Security.Client.Repository.Cache as Sec
import qualified Hackage.Security.Client.Repository.Local as Sec.Local
import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote
import qualified Distribution.Client.Security.HTTP as Sec.HTTP
import qualified Distribution.Client.Security.DNS as Sec.DNS
import qualified System.FilePath.Posix as FilePath.Posix
data GlobalFlags = GlobalFlags
{ GlobalFlags -> Flag Bool
globalVersion :: Flag Bool
, GlobalFlags -> Flag Bool
globalNumericVersion :: Flag Bool
, GlobalFlags -> Flag FilePath
globalConfigFile :: Flag FilePath
, GlobalFlags -> Flag FilePath
globalConstraintsFile :: Flag FilePath
, GlobalFlags -> NubList RemoteRepo
globalRemoteRepos :: NubList RemoteRepo
, GlobalFlags -> Flag FilePath
globalCacheDir :: Flag FilePath
, GlobalFlags -> NubList LocalRepo
globalLocalNoIndexRepos :: NubList LocalRepo
, GlobalFlags -> Flag ActiveRepos
globalActiveRepos :: Flag ActiveRepos
, GlobalFlags -> Flag FilePath
globalLogsDir :: Flag FilePath
, GlobalFlags -> Flag Bool
globalIgnoreExpiry :: Flag Bool
, GlobalFlags -> Flag FilePath
globalHttpTransport :: Flag String
, GlobalFlags -> Flag Bool
globalNix :: Flag Bool
, GlobalFlags -> Flag FilePath
globalStoreDir :: Flag FilePath
, :: NubList FilePath
} deriving (Int -> GlobalFlags -> ShowS
[GlobalFlags] -> ShowS
GlobalFlags -> FilePath
(Int -> GlobalFlags -> ShowS)
-> (GlobalFlags -> FilePath)
-> ([GlobalFlags] -> ShowS)
-> Show GlobalFlags
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [GlobalFlags] -> ShowS
$cshowList :: [GlobalFlags] -> ShowS
show :: GlobalFlags -> FilePath
$cshow :: GlobalFlags -> FilePath
showsPrec :: Int -> GlobalFlags -> ShowS
$cshowsPrec :: Int -> GlobalFlags -> ShowS
Show, (forall x. GlobalFlags -> Rep GlobalFlags x)
-> (forall x. Rep GlobalFlags x -> GlobalFlags)
-> Generic GlobalFlags
forall x. Rep GlobalFlags x -> GlobalFlags
forall x. GlobalFlags -> Rep GlobalFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GlobalFlags x -> GlobalFlags
$cfrom :: forall x. GlobalFlags -> Rep GlobalFlags x
Generic)
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags = GlobalFlags :: Flag Bool
-> Flag Bool
-> Flag FilePath
-> Flag FilePath
-> NubList RemoteRepo
-> Flag FilePath
-> NubList LocalRepo
-> Flag ActiveRepos
-> Flag FilePath
-> Flag Bool
-> Flag FilePath
-> Flag Bool
-> Flag FilePath
-> NubList FilePath
-> GlobalFlags
GlobalFlags
{ globalVersion :: Flag Bool
globalVersion = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
, globalNumericVersion :: Flag Bool
globalNumericVersion = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
, globalConfigFile :: Flag FilePath
globalConfigFile = Flag FilePath
forall a. Monoid a => a
mempty
, globalConstraintsFile :: Flag FilePath
globalConstraintsFile = Flag FilePath
forall a. Monoid a => a
mempty
, globalRemoteRepos :: NubList RemoteRepo
globalRemoteRepos = NubList RemoteRepo
forall a. Monoid a => a
mempty
, globalCacheDir :: Flag FilePath
globalCacheDir = Flag FilePath
forall a. Monoid a => a
mempty
, globalLocalNoIndexRepos :: NubList LocalRepo
globalLocalNoIndexRepos = NubList LocalRepo
forall a. Monoid a => a
mempty
, globalActiveRepos :: Flag ActiveRepos
globalActiveRepos = Flag ActiveRepos
forall a. Monoid a => a
mempty
, globalLogsDir :: Flag FilePath
globalLogsDir = Flag FilePath
forall a. Monoid a => a
mempty
, globalIgnoreExpiry :: Flag Bool
globalIgnoreExpiry = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
, globalHttpTransport :: Flag FilePath
globalHttpTransport = Flag FilePath
forall a. Monoid a => a
mempty
, globalNix :: Flag Bool
globalNix = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
, globalStoreDir :: Flag FilePath
globalStoreDir = Flag FilePath
forall a. Monoid a => a
mempty
, globalProgPathExtra :: NubList FilePath
globalProgPathExtra = NubList FilePath
forall a. Monoid a => a
mempty
}
instance Monoid GlobalFlags where
mempty :: GlobalFlags
mempty = GlobalFlags
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
mappend :: GlobalFlags -> GlobalFlags -> GlobalFlags
mappend = GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. Semigroup a => a -> a -> a
(<>)
instance Semigroup GlobalFlags where
<> :: GlobalFlags -> GlobalFlags -> GlobalFlags
(<>) = GlobalFlags -> GlobalFlags -> GlobalFlags
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend
data RepoContext = RepoContext {
RepoContext -> [Repo]
repoContextRepos :: [Repo]
, RepoContext -> IO HttpTransport
repoContextGetTransport :: IO HttpTransport
, RepoContext
-> forall a.
Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo :: forall a.
Repo
-> (forall down. Sec.Repository down -> IO a)
-> IO a
, RepoContext -> Bool
repoContextIgnoreExpiry :: Bool
}
data SecureRepo = forall down. SecureRepo (Sec.Repository down)
withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags =
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
forall a.
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
withRepoContext'
Verbosity
verbosity
(NubList RemoteRepo -> [RemoteRepo]
forall a. NubList a -> [a]
fromNubList (GlobalFlags -> NubList RemoteRepo
globalRemoteRepos GlobalFlags
globalFlags))
(NubList LocalRepo -> [LocalRepo]
forall a. NubList a -> [a]
fromNubList (GlobalFlags -> NubList LocalRepo
globalLocalNoIndexRepos GlobalFlags
globalFlags))
(Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (GlobalFlags -> Flag FilePath
globalCacheDir GlobalFlags
globalFlags))
(Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (GlobalFlags -> Flag FilePath
globalHttpTransport GlobalFlags
globalFlags))
(Flag Bool -> Maybe Bool
forall a. Flag a -> Maybe a
flagToMaybe (GlobalFlags -> Flag Bool
globalIgnoreExpiry GlobalFlags
globalFlags))
(NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList (GlobalFlags -> NubList FilePath
globalProgPathExtra GlobalFlags
globalFlags))
withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo]
-> FilePath -> Maybe String -> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
withRepoContext' :: Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
withRepoContext' Verbosity
verbosity [RemoteRepo]
remoteRepos [LocalRepo]
localNoIndexRepos
FilePath
sharedCacheDir Maybe FilePath
httpTransport Maybe Bool
ignoreExpiry [FilePath]
extraPaths = \RepoContext -> IO a
callback -> do
[LocalRepo] -> (LocalRepo -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [LocalRepo]
localNoIndexRepos ((LocalRepo -> IO ()) -> IO ()) -> (LocalRepo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LocalRepo
local ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
FilePath.Posix.isAbsolute (LocalRepo -> FilePath
localRepoPath LocalRepo
local)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"file+noindex " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName (LocalRepo -> RepoName
localRepoName LocalRepo
local) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" repository path is not absolute; this is fragile, and not recommended"
MVar (Maybe HttpTransport)
transportRef <- Maybe HttpTransport -> IO (MVar (Maybe HttpTransport))
forall a. a -> IO (MVar a)
newMVar Maybe HttpTransport
forall a. Maybe a
Nothing
let httpLib :: HttpLib
httpLib = Verbosity -> IO HttpTransport -> HttpLib
Sec.HTTP.transportAdapter
Verbosity
verbosity
(MVar (Maybe HttpTransport) -> IO HttpTransport
getTransport MVar (Maybe HttpTransport)
transportRef)
Verbosity
-> HttpLib
-> [(RemoteRepo, FilePath)]
-> (Map Repo SecureRepo -> IO a)
-> IO a
forall a.
Verbosity
-> HttpLib
-> [(RemoteRepo, FilePath)]
-> (Map Repo SecureRepo -> IO a)
-> IO a
initSecureRepos Verbosity
verbosity HttpLib
httpLib [(RemoteRepo, FilePath)]
secureRemoteRepos ((Map Repo SecureRepo -> IO a) -> IO a)
-> (Map Repo SecureRepo -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Map Repo SecureRepo
secureRepos' ->
RepoContext -> IO a
callback RepoContext :: [Repo]
-> IO HttpTransport
-> (forall a.
Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a)
-> Bool
-> RepoContext
RepoContext {
repoContextRepos :: [Repo]
repoContextRepos = [Repo]
allRemoteRepos
[Repo] -> [Repo] -> [Repo]
forall a. [a] -> [a] -> [a]
++ [Repo]
allLocalNoIndexRepos
, repoContextGetTransport :: IO HttpTransport
repoContextGetTransport = MVar (Maybe HttpTransport) -> IO HttpTransport
getTransport MVar (Maybe HttpTransport)
transportRef
, repoContextWithSecureRepo :: forall a.
Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo = Map Repo SecureRepo
-> Repo
-> (forall (down :: * -> *). Repository down -> IO a)
-> IO a
forall a.
Map Repo SecureRepo
-> Repo
-> (forall (down :: * -> *). Repository down -> IO a)
-> IO a
withSecureRepo Map Repo SecureRepo
secureRepos'
, repoContextIgnoreExpiry :: Bool
repoContextIgnoreExpiry = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
ignoreExpiry
}
where
secureRemoteRepos :: [(RemoteRepo, FilePath)]
secureRemoteRepos =
[ (RemoteRepo
remote, FilePath
cacheDir) | RepoSecure RemoteRepo
remote FilePath
cacheDir <- [Repo]
allRemoteRepos ]
allRemoteRepos :: [Repo]
allRemoteRepos :: [Repo]
allRemoteRepos =
[ (if Bool
isSecure then RemoteRepo -> FilePath -> Repo
RepoSecure else RemoteRepo -> FilePath -> Repo
RepoRemote) RemoteRepo
remote FilePath
cacheDir
| RemoteRepo
remote <- [RemoteRepo]
remoteRepos
, let cacheDir :: FilePath
cacheDir = FilePath
sharedCacheDir FilePath -> ShowS
</> RepoName -> FilePath
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
remote)
isSecure :: Bool
isSecure = RemoteRepo -> Maybe Bool
remoteRepoSecure RemoteRepo
remote Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
]
allLocalNoIndexRepos :: [Repo]
allLocalNoIndexRepos :: [Repo]
allLocalNoIndexRepos =
[ LocalRepo -> FilePath -> Repo
RepoLocalNoIndex LocalRepo
local FilePath
cacheDir
| LocalRepo
local <- [LocalRepo]
localNoIndexRepos
, let cacheDir :: FilePath
cacheDir | LocalRepo -> Bool
localRepoSharedCache LocalRepo
local = FilePath
sharedCacheDir FilePath -> ShowS
</> LocalRepo -> FilePath
localRepoCacheKey LocalRepo
local
| Bool
otherwise = LocalRepo -> FilePath
localRepoPath LocalRepo
local
]
getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport
getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport
getTransport MVar (Maybe HttpTransport)
transportRef =
MVar (Maybe HttpTransport)
-> (Maybe HttpTransport -> IO (Maybe HttpTransport, HttpTransport))
-> IO HttpTransport
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe HttpTransport)
transportRef ((Maybe HttpTransport -> IO (Maybe HttpTransport, HttpTransport))
-> IO HttpTransport)
-> (Maybe HttpTransport -> IO (Maybe HttpTransport, HttpTransport))
-> IO HttpTransport
forall a b. (a -> b) -> a -> b
$ \Maybe HttpTransport
mTransport -> do
HttpTransport
transport <- case Maybe HttpTransport
mTransport of
Just HttpTransport
tr -> HttpTransport -> IO HttpTransport
forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
tr
Maybe HttpTransport
Nothing -> Verbosity -> [FilePath] -> Maybe FilePath -> IO HttpTransport
configureTransport Verbosity
verbosity [FilePath]
extraPaths Maybe FilePath
httpTransport
(Maybe HttpTransport, HttpTransport)
-> IO (Maybe HttpTransport, HttpTransport)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpTransport -> Maybe HttpTransport
forall a. a -> Maybe a
Just HttpTransport
transport, HttpTransport
transport)
withSecureRepo :: Map Repo SecureRepo
-> Repo
-> (forall down. Sec.Repository down -> IO a)
-> IO a
withSecureRepo :: Map Repo SecureRepo
-> Repo
-> (forall (down :: * -> *). Repository down -> IO a)
-> IO a
withSecureRepo Map Repo SecureRepo
secureRepos Repo
repo forall (down :: * -> *). Repository down -> IO a
callback =
case Repo -> Map Repo SecureRepo -> Maybe SecureRepo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Repo
repo Map Repo SecureRepo
secureRepos of
Just (SecureRepo Repository down
secureRepo) -> Repository down -> IO a
forall (down :: * -> *). Repository down -> IO a
callback Repository down
secureRepo
Maybe SecureRepo
Nothing -> IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError FilePath
"repoContextWithSecureRepo: unknown repo"
initSecureRepos :: forall a. Verbosity
-> Sec.HTTP.HttpLib
-> [(RemoteRepo, FilePath)]
-> (Map Repo SecureRepo -> IO a)
-> IO a
initSecureRepos :: Verbosity
-> HttpLib
-> [(RemoteRepo, FilePath)]
-> (Map Repo SecureRepo -> IO a)
-> IO a
initSecureRepos Verbosity
verbosity HttpLib
httpLib [(RemoteRepo, FilePath)]
repos Map Repo SecureRepo -> IO a
callback = Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
go Map Repo SecureRepo
forall k a. Map k a
Map.empty [(RemoteRepo, FilePath)]
repos
where
go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
go !Map Repo SecureRepo
acc [] = Map Repo SecureRepo -> IO a
callback Map Repo SecureRepo
acc
go !Map Repo SecureRepo
acc ((RemoteRepo
r,FilePath
cacheDir):[(RemoteRepo, FilePath)]
rs) = do
Path Absolute
cachePath <- FsPath -> IO (Path Absolute)
Sec.makeAbsolute (FsPath -> IO (Path Absolute)) -> FsPath -> IO (Path Absolute)
forall a b. (a -> b) -> a -> b
$ FilePath -> FsPath
Sec.fromFilePath FilePath
cacheDir
Verbosity
-> HttpLib
-> RemoteRepo
-> Path Absolute
-> (SecureRepo -> IO a)
-> IO a
forall a.
Verbosity
-> HttpLib
-> RemoteRepo
-> Path Absolute
-> (SecureRepo -> IO a)
-> IO a
initSecureRepo Verbosity
verbosity HttpLib
httpLib RemoteRepo
r Path Absolute
cachePath ((SecureRepo -> IO a) -> IO a) -> (SecureRepo -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SecureRepo
r' ->
Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
go (Repo -> SecureRepo -> Map Repo SecureRepo -> Map Repo SecureRepo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (RemoteRepo -> FilePath -> Repo
RepoSecure RemoteRepo
r FilePath
cacheDir) SecureRepo
r' Map Repo SecureRepo
acc) [(RemoteRepo, FilePath)]
rs
initSecureRepo :: Verbosity
-> Sec.HTTP.HttpLib
-> RemoteRepo
-> Sec.Path Sec.Absolute
-> (SecureRepo -> IO a)
-> IO a
initSecureRepo :: Verbosity
-> HttpLib
-> RemoteRepo
-> Path Absolute
-> (SecureRepo -> IO a)
-> IO a
initSecureRepo Verbosity
verbosity HttpLib
httpLib RemoteRepo{Bool
Int
[FilePath]
Maybe Bool
URI
RepoName
remoteRepoShouldTryHttps :: RemoteRepo -> Bool
remoteRepoKeyThreshold :: RemoteRepo -> Int
remoteRepoRootKeys :: RemoteRepo -> [FilePath]
remoteRepoURI :: RemoteRepo -> URI
remoteRepoShouldTryHttps :: Bool
remoteRepoKeyThreshold :: Int
remoteRepoRootKeys :: [FilePath]
remoteRepoSecure :: Maybe Bool
remoteRepoURI :: URI
remoteRepoName :: RepoName
remoteRepoSecure :: RemoteRepo -> Maybe Bool
remoteRepoName :: RemoteRepo -> RepoName
..} Path Absolute
cachePath = \SecureRepo -> IO a
callback -> do
Bool
requiresBootstrap <- [URI]
-> (forall (down :: * -> *). Repository down -> IO Bool) -> IO Bool
forall a.
[URI] -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
withRepo [] forall (down :: * -> *). Repository down -> IO Bool
Sec.requiresBootstrap
[URI]
mirrors <- if Bool
requiresBootstrap
then do
Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Trying to locate mirrors via DNS for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
FilePath
"initial bootstrap of secure " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
FilePath
"repository '" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> FilePath
forall a. Show a => a -> FilePath
show URI
remoteRepoURI FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
FilePath
"' ..."
Verbosity -> URI -> IO [URI]
Sec.DNS.queryBootstrapMirrors Verbosity
verbosity URI
remoteRepoURI
else [URI] -> IO [URI]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
[URI] -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
forall a.
[URI] -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
withRepo [URI]
mirrors ((forall (down :: * -> *). Repository down -> IO a) -> IO a)
-> (forall (down :: * -> *). Repository down -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Repository down
r -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
requiresBootstrap (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO ())
-> IO ()
forall a.
((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO a)
-> IO a
Sec.uncheckClientErrors (((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO ())
-> IO ())
-> ((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
Repository down -> [KeyId] -> KeyThreshold -> IO ()
forall (down :: * -> *).
(Throws SomeRemoteError, Throws VerificationError) =>
Repository down -> [KeyId] -> KeyThreshold -> IO ()
Sec.bootstrap Repository down
r
((FilePath -> KeyId) -> [FilePath] -> [KeyId]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> KeyId
Sec.KeyId [FilePath]
remoteRepoRootKeys)
(Int54 -> KeyThreshold
Sec.KeyThreshold (Int -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
remoteRepoKeyThreshold))
SecureRepo -> IO a
callback (SecureRepo -> IO a) -> SecureRepo -> IO a
forall a b. (a -> b) -> a -> b
$ Repository down -> SecureRepo
forall (down :: * -> *). Repository down -> SecureRepo
SecureRepo Repository down
r
where
withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a
withRepo :: [URI] -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
withRepo [URI]
_ forall (down :: * -> *). Repository down -> IO a
callback | URI -> FilePath
uriScheme URI
remoteRepoURI FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"file:" = do
Path Absolute
dir <- FsPath -> IO (Path Absolute)
Sec.makeAbsolute (FsPath -> IO (Path Absolute)) -> FsPath -> IO (Path Absolute)
forall a b. (a -> b) -> a -> b
$ FilePath -> FsPath
Sec.fromFilePath (URI -> FilePath
uriPath URI
remoteRepoURI)
Path Absolute
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository LocalFile -> IO a)
-> IO a
forall a.
Path Absolute
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository LocalFile -> IO a)
-> IO a
Sec.Local.withRepository Path Absolute
dir
Cache
cache
RepoLayout
Sec.hackageRepoLayout
IndexLayout
Sec.hackageIndexLayout
LogMessage -> IO ()
logTUF
Repository LocalFile -> IO a
forall (down :: * -> *). Repository down -> IO a
callback
withRepo [URI]
mirrors forall (down :: * -> *). Repository down -> IO a
callback =
HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
forall a.
HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
Sec.Remote.withRepository HttpLib
httpLib
(URI
remoteRepoURIURI -> [URI] -> [URI]
forall a. a -> [a] -> [a]
:[URI]
mirrors)
RepoOpts
Sec.Remote.defaultRepoOpts
Cache
cache
RepoLayout
Sec.hackageRepoLayout
IndexLayout
Sec.hackageIndexLayout
LogMessage -> IO ()
logTUF
Repository RemoteTemp -> IO a
forall (down :: * -> *). Repository down -> IO a
callback
cache :: Sec.Cache
cache :: Cache
cache = Cache :: Path Absolute -> CacheLayout -> Cache
Sec.Cache {
cacheRoot :: Path Absolute
cacheRoot = Path Absolute
cachePath
, cacheLayout :: CacheLayout
cacheLayout = CacheLayout
Sec.cabalCacheLayout {
cacheLayoutIndexTar :: CachePath
Sec.cacheLayoutIndexTar = FilePath -> CachePath
cacheFn FilePath
"01-index.tar"
, cacheLayoutIndexIdx :: CachePath
Sec.cacheLayoutIndexIdx = FilePath -> CachePath
cacheFn FilePath
"01-index.tar.idx"
, cacheLayoutIndexTarGz :: CachePath
Sec.cacheLayoutIndexTarGz = FilePath -> CachePath
cacheFn FilePath
"01-index.tar.gz"
}
}
cacheFn :: FilePath -> Sec.CachePath
cacheFn :: FilePath -> CachePath
cacheFn = Path Unrooted -> CachePath
forall root. Path Unrooted -> Path root
Sec.rootPath (Path Unrooted -> CachePath)
-> (FilePath -> Path Unrooted) -> FilePath -> CachePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Path Unrooted
Sec.fragment
logTUF :: Sec.LogMessage -> IO ()
logTUF :: LogMessage -> IO ()
logTUF = Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ())
-> (LogMessage -> FilePath) -> LogMessage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> FilePath
forall a. Pretty a => a -> FilePath
Sec.pretty