{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Client.GlobalFlags
  ( GlobalFlags (..)
  , defaultGlobalFlags
  , RepoContext (..)
  , withRepoContext
  , withRepoContext'
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.HttpUtils
  ( HttpTransport
  , configureTransport
  )
import Distribution.Client.Types
  ( LocalRepo (..)
  , RemoteRepo (..)
  , Repo (..)
  , localRepoCacheKey
  , unRepoName
  )
import Distribution.Simple.Setup
  ( Flag (..)
  , flagToMaybe
  , fromFlag
  )
import Distribution.Simple.Utils
  ( info
  , warn
  )
import Distribution.Utils.NubList
  ( NubList
  , fromNubList
  )

import Distribution.Client.IndexUtils.ActiveRepos
  ( ActiveRepos
  )

import Control.Concurrent
  ( MVar
  , modifyMVar
  , newMVar
  )
import qualified Data.Map as Map
import Network.URI
  ( URI
  , uriPath
  , uriScheme
  )
import System.FilePath
  ( isAbsolute
  , (</>)
  )

import qualified Distribution.Client.Security.DNS as Sec.DNS
import qualified Distribution.Client.Security.HTTP as Sec.HTTP
import qualified Hackage.Security.Client 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 Hackage.Security.Util.Path as Sec
import qualified Hackage.Security.Util.Pretty as Sec

-- ------------------------------------------------------------

-- * 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
$cshowsPrec :: Int -> GlobalFlags -> ShowS
showsPrec :: Int -> GlobalFlags -> ShowS
$cshow :: GlobalFlags -> FilePath
show :: GlobalFlags -> FilePath
$cshowList :: [GlobalFlags] -> ShowS
showList :: [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
$cfrom :: forall x. GlobalFlags -> Rep GlobalFlags x
from :: forall x. GlobalFlags -> Rep GlobalFlags x
$cto :: forall x. Rep GlobalFlags x -> GlobalFlags
to :: forall x. Rep GlobalFlags x -> GlobalFlags
Generic)

defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags =
  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
  { RepoContext -> [Repo]
repoContextRepos :: [Repo]
  -- ^ All user-specified repositories
  , RepoContext -> IO HttpTransport
repoContextGetTransport :: IO HttpTransport
  -- ^ 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
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo
      :: forall a
       . Repo
      -> (forall down. Sec.Repository down -> IO a)
      -> IO a
  -- ^ Get the (initialized) secure repo
  --
  -- (the 'Repo' type itself is stateless and must remain so, because it
  -- must be serializable)
  , RepoContext -> Bool
repoContextIgnoreExpiry :: Bool
  -- ^ Should we ignore expiry times (when checking security)?
  }

-- | Wrapper around 'Repository', hiding the type argument
data SecureRepo = forall down. SecureRepo (Sec.Repository down)

withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext :: forall a. 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' :: forall a.
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
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
          { 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 a. a -> IO a
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 a. a -> IO a
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 :: forall a.
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 :: forall a.
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 :: forall a.
Verbosity
-> HttpLib
-> RemoteRepo
-> Path Absolute
-> (SecureRepo -> IO a)
-> IO a
initSecureRepo Verbosity
verbosity HttpLib
httpLib RemoteRepo{Bool
Int
[FilePath]
Maybe Bool
URI
RepoName
remoteRepoName :: RemoteRepo -> RepoName
remoteRepoSecure :: RemoteRepo -> Maybe Bool
remoteRepoName :: RepoName
remoteRepoURI :: URI
remoteRepoSecure :: Maybe Bool
remoteRepoRootKeys :: [FilePath]
remoteRepoKeyThreshold :: Int
remoteRepoShouldTryHttps :: Bool
remoteRepoURI :: RemoteRepo -> URI
remoteRepoRootKeys :: RemoteRepo -> [FilePath]
remoteRepoKeyThreshold :: RemoteRepo -> Int
remoteRepoShouldTryHttps :: RemoteRepo -> Bool
..} 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 [] Repository down -> IO Bool
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 a. a -> IO a
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 :: forall a.
[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
remoteRepoURI URI -> [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 =
      Sec.Cache
        { cacheRoot :: Path Absolute
cacheRoot = Path Absolute
cachePath
        , cacheLayout :: CacheLayout
cacheLayout =
            CacheLayout
Sec.cabalCacheLayout
              { Sec.cacheLayoutIndexTar = cacheFn "01-index.tar"
              , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx"
              , Sec.cacheLayoutIndexTarGz = cacheFn "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