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