cabal-install/src/Distribution/Client/GlobalFlags.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE ExistentialQuantification #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7
   8 module Distribution.Client.GlobalFlags
   9   ( GlobalFlags (..)
  10   , defaultGlobalFlags
  11   , RepoContext (..)
  12   , withRepoContext
  13   , withRepoContext'
  14   ) where
  15
  16 import Distribution.Client.Compat.Prelude
  17 import Prelude ()
  18
  19 import Distribution.Client.HttpUtils
  20   ( HttpTransport
  21   , configureTransport
  22   )
  23 import Distribution.Client.Types
  24   ( LocalRepo (..)
  25   , RemoteRepo (..)
  26   , Repo (..)
  27   , localRepoCacheKey
  28   , unRepoName
  29   )
  30 import Distribution.Simple.Setup
  31   ( Flag (..)
  32   , flagToMaybe
  33   , fromFlag
  34   )
  35 import Distribution.Simple.Utils
  36   ( info
  37   , warn
  38   )
  39 import Distribution.Utils.NubList
  40   ( NubList
  41   , fromNubList
  42   )
  43
  44 import Distribution.Client.IndexUtils.ActiveRepos
  45   ( ActiveRepos
  46   )
  47
  48 import Control.Concurrent
  49   ( MVar
  50   , modifyMVar
  51   , newMVar
  52   )
  53 import qualified Data.Map as Map
  54 import Network.URI
  55   ( URI
  56   , uriPath
  57   , uriScheme
  58   )
  59 import System.FilePath
  60   ( (</>)
  61   )
  62
  63 import qualified Distribution.Client.Security.DNS as Sec.DNS
  64 import qualified Distribution.Client.Security.HTTP as Sec.HTTP
  65 import qualified Hackage.Security.Client as Sec
  66 import qualified Hackage.Security.Client.Repository.Cache as Sec
  67 import qualified Hackage.Security.Client.Repository.Local as Sec.Local
  68 import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote
  69 import qualified Hackage.Security.Util.Path as Sec
  70 import qualified Hackage.Security.Util.Pretty as Sec
  71
  72 import qualified System.FilePath.Posix as FilePath.Posix
  73
  74 -- ------------------------------------------------------------
  75
  76 -- * Global flags
  77
  78 -- ------------------------------------------------------------
  79
  80 -- | Flags that apply at the top level, not to any sub-command.
  81 data GlobalFlags = GlobalFlags
  82   { globalVersion :: Flag Bool
  83   , globalNumericVersion :: Flag Bool
  84   , globalConfigFile :: Flag FilePath
  85   , globalConstraintsFile :: Flag FilePath
  86   , globalRemoteRepos :: NubList RemoteRepo
  87   -- ^ Available Hackage servers.
  88   , globalCacheDir :: Flag FilePath
  89   , globalLocalNoIndexRepos :: NubList LocalRepo
  90   , globalActiveRepos :: Flag ActiveRepos
  91   , globalLogsDir :: Flag FilePath
  92   , globalIgnoreExpiry :: Flag Bool
  93   -- ^ Ignore security expiry dates
  94   , globalHttpTransport :: Flag String
  95   , globalNix :: Flag Bool
  96   -- ^ Integrate with Nix
  97   , globalStoreDir :: Flag FilePath
  98   , globalProgPathExtra :: NubList FilePath
  99   -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
 100   }
 101   deriving (Show, Generic)
 102
 103 defaultGlobalFlags :: GlobalFlags
 104 defaultGlobalFlags =
 105   GlobalFlags
 106     { globalVersion = Flag False
 107     , globalNumericVersion = Flag False
 108     , globalConfigFile = mempty
 109     , globalConstraintsFile = mempty
 110     , globalRemoteRepos = mempty
 111     , globalCacheDir = mempty
 112     , globalLocalNoIndexRepos = mempty
 113     , globalActiveRepos = mempty
 114     , globalLogsDir = mempty
 115     , globalIgnoreExpiry = Flag False
 116     , globalHttpTransport = mempty
 117     , globalNix = Flag False
 118     , globalStoreDir = mempty
 119     , globalProgPathExtra = mempty
 120     }
 121
 122 instance Monoid GlobalFlags where
 123   mempty = gmempty
 124   mappend = (<>)
 125
 126 instance Semigroup GlobalFlags where
 127   (<>) = gmappend
 128
 129 -- ------------------------------------------------------------
 130
 131 -- * Repo context
 132
 133 -- ------------------------------------------------------------
 134
 135 -- | Access to repositories
 136 data RepoContext = RepoContext
 137   { repoContextRepos :: [Repo]
 138   -- ^ All user-specified repositories
 139   , repoContextGetTransport :: IO HttpTransport
 140   -- ^ Get the HTTP transport
 141   --
 142   -- The transport will be initialized on the first call to this function.
 143   --
 144   -- NOTE: It is important that we don't eagerly initialize the transport.
 145   -- Initializing the transport is not free, and especially in contexts where
 146   -- we don't know a priori whether or not we need the transport (for instance
 147   -- when using cabal in "nix mode") incurring the overhead of transport
 148   -- initialization on _every_ invocation (eg @cabal build@) is undesirable.
 149   , repoContextWithSecureRepo
 150       :: forall a
 151        . Repo
 152       -> (forall down. Sec.Repository down -> IO a)
 153       -> IO a
 154   -- ^ Get the (initialized) secure repo
 155   --
 156   -- (the 'Repo' type itself is stateless and must remain so, because it
 157   -- must be serializable)
 158   , repoContextIgnoreExpiry :: Bool
 159   -- ^ Should we ignore expiry times (when checking security)?
 160   }
 161
 162 -- | Wrapper around 'Repository', hiding the type argument
 163 data SecureRepo = forall down. SecureRepo (Sec.Repository down)
 164
 165 withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
 166 withRepoContext verbosity globalFlags =
 167   withRepoContext'
 168     verbosity
 169     (fromNubList (globalRemoteRepos globalFlags))
 170     (fromNubList (globalLocalNoIndexRepos globalFlags))
 171     (fromFlag (globalCacheDir globalFlags))
 172     (flagToMaybe (globalHttpTransport globalFlags))
 173     (flagToMaybe (globalIgnoreExpiry globalFlags))
 174     (fromNubList (globalProgPathExtra globalFlags))
 175
 176 withRepoContext'
 177   :: Verbosity
 178   -> [RemoteRepo]
 179   -> [LocalRepo]
 180   -> FilePath
 181   -> Maybe String
 182   -> Maybe Bool
 183   -> [FilePath]
 184   -> (RepoContext -> IO a)
 185   -> IO a
 186 withRepoContext'
 187   verbosity
 188   remoteRepos
 189   localNoIndexRepos
 190   sharedCacheDir
 191   httpTransport
 192   ignoreExpiry
 193   extraPaths = \callback -> do
 194     for_ localNoIndexRepos $ \local ->
 195       unless (FilePath.Posix.isAbsolute (localRepoPath local)) $
 196         warn verbosity $
 197           "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"
 198
 199     transportRef <- newMVar Nothing
 200     let httpLib =
 201           Sec.HTTP.transportAdapter
 202             verbosity
 203             (getTransport transportRef)
 204     initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' ->
 205       callback
 206         RepoContext
 207           { repoContextRepos =
 208               allRemoteRepos
 209                 ++ allLocalNoIndexRepos
 210           , repoContextGetTransport = getTransport transportRef
 211           , repoContextWithSecureRepo = withSecureRepo secureRepos'
 212           , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry
 213           }
 214     where
 215       secureRemoteRepos =
 216         [(remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos]
 217
 218       allRemoteRepos :: [Repo]
 219       allRemoteRepos =
 220         [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir
 221         | remote <- remoteRepos
 222         , let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)
 223               isSecure = remoteRepoSecure remote == Just True
 224         ]
 225
 226       allLocalNoIndexRepos :: [Repo]
 227       allLocalNoIndexRepos =
 228         [ RepoLocalNoIndex local cacheDir
 229         | local <- localNoIndexRepos
 230         , let cacheDir
 231                 | localRepoSharedCache local = sharedCacheDir </> localRepoCacheKey local
 232                 | otherwise = localRepoPath local
 233         ]
 234
 235       getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport
 236       getTransport transportRef =
 237         modifyMVar transportRef $ \mTransport -> do
 238           transport <- case mTransport of
 239             Just tr -> return tr
 240             Nothing -> configureTransport verbosity extraPaths httpTransport
 241           return (Just transport, transport)
 242
 243       withSecureRepo
 244         :: Map Repo SecureRepo
 245         -> Repo
 246         -> (forall down. Sec.Repository down -> IO a)
 247         -> IO a
 248       withSecureRepo secureRepos repo callback =
 249         case Map.lookup repo secureRepos of
 250           Just (SecureRepo secureRepo) -> callback secureRepo
 251           Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo"
 252
 253 -- | Initialize the provided secure repositories
 254 --
 255 -- Assumed invariant: `remoteRepoSecure` should be set for all these repos.
 256 initSecureRepos
 257   :: forall a
 258    . Verbosity
 259   -> Sec.HTTP.HttpLib
 260   -> [(RemoteRepo, FilePath)]
 261   -> (Map Repo SecureRepo -> IO a)
 262   -> IO a
 263 initSecureRepos verbosity httpLib repos callback = go Map.empty repos
 264   where
 265     go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
 266     go !acc [] = callback acc
 267     go !acc ((r, cacheDir) : rs) = do
 268       cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir
 269       initSecureRepo verbosity httpLib r cachePath $ \r' ->
 270         go (Map.insert (RepoSecure r cacheDir) r' acc) rs
 271
 272 -- | Initialize the given secure repo
 273 --
 274 -- The security library has its own concept of a "local" repository, distinct
 275 -- from @cabal-install@'s; these are secure repositories, but live in the local
 276 -- file system. We use the convention that these repositories are identified by
 277 -- URLs of the form @file:/path/to/local/repo@.
 278 initSecureRepo
 279   :: Verbosity
 280   -> Sec.HTTP.HttpLib
 281   -> RemoteRepo
 282   -- ^ Secure repo ('remoteRepoSecure' assumed)
 283   -> Sec.Path Sec.Absolute
 284   -- ^ Cache dir
 285   -> (SecureRepo -> IO a)
 286   -- ^ Callback
 287   -> IO a
 288 initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do
 289   requiresBootstrap <- withRepo [] Sec.requiresBootstrap
 290
 291   mirrors <-
 292     if requiresBootstrap
 293       then do
 294         info verbosity $
 295           "Trying to locate mirrors via DNS for "
 296             ++ "initial bootstrap of secure "
 297             ++ "repository '"
 298             ++ show remoteRepoURI
 299             ++ "' ..."
 300
 301         Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI
 302       else pure []
 303
 304   withRepo mirrors $ \r -> do
 305     when requiresBootstrap $
 306       Sec.uncheckClientErrors $
 307         Sec.bootstrap
 308           r
 309           (map Sec.KeyId remoteRepoRootKeys)
 310           (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold))
 311     callback $ SecureRepo r
 312   where
 313     -- Initialize local or remote repo depending on the URI
 314     withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a
 315     withRepo _ callback | uriScheme remoteRepoURI == "file:" = do
 316       dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)
 317       Sec.Local.withRepository
 318         dir
 319         cache
 320         Sec.hackageRepoLayout
 321         Sec.hackageIndexLayout
 322         logTUF
 323         callback
 324     withRepo mirrors callback =
 325       Sec.Remote.withRepository
 326         httpLib
 327         (remoteRepoURI : mirrors)
 328         Sec.Remote.defaultRepoOpts
 329         cache
 330         Sec.hackageRepoLayout
 331         Sec.hackageIndexLayout
 332         logTUF
 333         callback
 334
 335     cache :: Sec.Cache
 336     cache =
 337       Sec.Cache
 338         { cacheRoot = cachePath
 339         , cacheLayout =
 340             Sec.cabalCacheLayout
 341               { Sec.cacheLayoutIndexTar = cacheFn "01-index.tar"
 342               , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx"
 343               , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz"
 344               }
 345         }
 346
 347     cacheFn :: FilePath -> Sec.CachePath
 348     cacheFn = Sec.rootPath . Sec.fragment
 349
 350     -- We display any TUF progress only in verbose mode, including any transient
 351     -- verification errors. If verification fails, then the final exception that
 352     -- is thrown will of course be shown.
 353     logTUF :: Sec.LogMessage -> IO ()
 354     logTUF = info verbosity . Sec.pretty