{-# 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

-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- | Flags that apply at the top level, not to any sub-command.

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     -- ^ Available Hackage servers.
    , 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    -- ^ Ignore security expiry dates
    , GlobalFlags -> Flag FilePath
globalHttpTransport     :: Flag String
    , GlobalFlags -> Flag Bool
globalNix               :: Flag Bool  -- ^ Integrate with Nix
    , GlobalFlags -> Flag FilePath
globalStoreDir          :: Flag FilePath
    , GlobalFlags -> NubList FilePath
globalProgPathExtra     :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
    } 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

-- ------------------------------------------------------------
-- * Repo context
-- ------------------------------------------------------------

-- | Access to repositories
data RepoContext = RepoContext {
    -- | All user-specified repositories
    RepoContext -> [Repo]
repoContextRepos :: [Repo]

    -- | Get the HTTP transport
    --
    -- The transport will be initialized on the first call to this function.
    --
    -- NOTE: It is important that we don't eagerly initialize the transport.
    -- Initializing the transport is not free, and especially in contexts where
    -- we don't know a priori whether or not we need the transport (for instance
    -- when using cabal in "nix mode") incurring the overhead of transport
    -- initialization on _every_ invocation (eg @cabal build@) is undesirable.
  , RepoContext -> IO HttpTransport
repoContextGetTransport :: IO HttpTransport

    -- | Get the (initialized) secure repo
    --
    -- (the 'Repo' type itself is stateless and must remain so, because it
    -- must be serializable)
  , 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

    -- | Should we ignore expiry times (when checking security)?
  , RepoContext -> Bool
repoContextIgnoreExpiry :: Bool
  }

-- | Wrapper around 'Repository', hiding the type argument
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"

-- | Initialize the provided secure repositories
--
-- Assumed invariant: `remoteRepoSecure` should be set for all these repos.
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

-- | Initialize the given secure repo
--
-- The security library has its own concept of a "local" repository, distinct
-- from @cabal-install@'s; these are secure repositories, but live in the local
-- file system. We use the convention that these repositories are identified by
-- URLs of the form @file:/path/to/local/repo@.
initSecureRepo :: Verbosity
               -> Sec.HTTP.HttpLib
               -> RemoteRepo  -- ^ Secure repo ('remoteRepoSecure' assumed)
               -> Sec.Path Sec.Absolute -- ^ Cache dir
               -> (SecureRepo -> IO a)  -- ^ Callback
               -> 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
    -- Initialize local or remote repo depending on the URI
    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

    -- We display any TUF progress only in verbose mode, including any transient
    -- verification errors. If verification fails, then the final exception that
    -- is thrown will of course be shown.
    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