{-# 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
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. 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
{ globalVersion :: Flag Bool
globalVersion = forall a. a -> Flag a
Flag Bool
False
, globalNumericVersion :: Flag Bool
globalNumericVersion = forall a. a -> Flag a
Flag Bool
False
, globalConfigFile :: Flag FilePath
globalConfigFile = forall a. Monoid a => a
mempty
, globalConstraintsFile :: Flag FilePath
globalConstraintsFile = forall a. Monoid a => a
mempty
, globalRemoteRepos :: NubList RemoteRepo
globalRemoteRepos = forall a. Monoid a => a
mempty
, globalCacheDir :: Flag FilePath
globalCacheDir = forall a. Monoid a => a
mempty
, globalLocalNoIndexRepos :: NubList LocalRepo
globalLocalNoIndexRepos = forall a. Monoid a => a
mempty
, globalActiveRepos :: Flag ActiveRepos
globalActiveRepos = forall a. Monoid a => a
mempty
, globalLogsDir :: Flag FilePath
globalLogsDir = forall a. Monoid a => a
mempty
, globalIgnoreExpiry :: Flag Bool
globalIgnoreExpiry = forall a. a -> Flag a
Flag Bool
False
, globalHttpTransport :: Flag FilePath
globalHttpTransport = forall a. Monoid a => a
mempty
, globalNix :: Flag Bool
globalNix = forall a. a -> Flag a
Flag Bool
False
, globalStoreDir :: Flag FilePath
globalStoreDir = forall a. Monoid a => a
mempty
, globalProgPathExtra :: NubList FilePath
globalProgPathExtra = forall a. Monoid a => a
mempty
}
instance Monoid GlobalFlags where
mempty :: GlobalFlags
mempty = forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
mappend :: GlobalFlags -> GlobalFlags -> GlobalFlags
mappend = forall a. Semigroup a => a -> a -> a
(<>)
instance Semigroup GlobalFlags where
<> :: 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 :: forall a. Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext Verbosity
verbosity GlobalFlags
globalFlags =
forall a.
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
withRepoContext'
Verbosity
verbosity
(forall a. NubList a -> [a]
fromNubList (GlobalFlags -> NubList RemoteRepo
globalRemoteRepos GlobalFlags
globalFlags))
(forall a. NubList a -> [a]
fromNubList (GlobalFlags -> NubList LocalRepo
globalLocalNoIndexRepos GlobalFlags
globalFlags))
(forall a. WithCallStack (Flag a -> a)
fromFlag (GlobalFlags -> Flag FilePath
globalCacheDir GlobalFlags
globalFlags))
(forall a. Flag a -> Maybe a
flagToMaybe (GlobalFlags -> Flag FilePath
globalHttpTransport GlobalFlags
globalFlags))
(forall a. Flag a -> Maybe a
flagToMaybe (GlobalFlags -> Flag Bool
globalIgnoreExpiry GlobalFlags
globalFlags))
(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
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [LocalRepo]
localNoIndexRepos forall a b. (a -> b) -> a -> b
$ \LocalRepo
local ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
FilePath.Posix.isAbsolute (LocalRepo -> FilePath
localRepoPath LocalRepo
local)) forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"file+noindex " forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName (LocalRepo -> RepoName
localRepoName LocalRepo
local) forall a. [a] -> [a] -> [a]
++ FilePath
" repository path is not absolute; this is fragile, and not recommended"
MVar (Maybe HttpTransport)
transportRef <- forall a. a -> IO (MVar a)
newMVar 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)
forall a.
Verbosity
-> HttpLib
-> [(RemoteRepo, FilePath)]
-> (Map Repo SecureRepo -> IO a)
-> IO a
initSecureRepos Verbosity
verbosity HttpLib
httpLib [(RemoteRepo, FilePath)]
secureRemoteRepos forall a b. (a -> b) -> a -> b
$ \Map Repo SecureRepo
secureRepos' ->
RepoContext -> IO a
callback RepoContext {
repoContextRepos :: [Repo]
repoContextRepos = [Repo]
allRemoteRepos
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 = forall a.
Map Repo SecureRepo
-> Repo
-> (forall (down :: * -> *). Repository down -> IO a)
-> IO a
withSecureRepo Map Repo SecureRepo
secureRepos'
, repoContextIgnoreExpiry :: Bool
repoContextIgnoreExpiry = 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 forall a. Eq a => a -> a -> 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 =
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe HttpTransport)
transportRef forall a b. (a -> b) -> a -> b
$ \Maybe HttpTransport
mTransport -> do
HttpTransport
transport <- case Maybe HttpTransport
mTransport of
Just HttpTransport
tr -> 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
forall (m :: * -> *) a. Monad m => a -> m a
return (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 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) -> forall (down :: * -> *). Repository down -> IO a
callback Repository down
secureRepo
Maybe SecureRepo
Nothing -> forall e a. Exception e => e -> IO a
throwIO 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 :: 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 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 forall a b. (a -> b) -> a -> b
$ FilePath -> FsPath
Sec.fromFilePath FilePath
cacheDir
forall a.
Verbosity
-> HttpLib
-> RemoteRepo
-> Path Absolute
-> (SecureRepo -> IO a)
-> IO a
initSecureRepo Verbosity
verbosity HttpLib
httpLib RemoteRepo
r Path Absolute
cachePath forall a b. (a -> b) -> a -> b
$ \SecureRepo
r' ->
Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
go (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 :: 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
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 <- 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 forall a b. (a -> b) -> a -> b
$ FilePath
"Trying to locate mirrors via DNS for " forall a. [a] -> [a] -> [a]
++
FilePath
"initial bootstrap of secure " forall a. [a] -> [a] -> [a]
++
FilePath
"repository '" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show URI
remoteRepoURI forall a. [a] -> [a] -> [a]
++
FilePath
"' ..."
Verbosity -> URI -> IO [URI]
Sec.DNS.queryBootstrapMirrors Verbosity
verbosity URI
remoteRepoURI
else forall (f :: * -> *) a. Applicative f => a -> f a
pure []
forall a.
[URI] -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
withRepo [URI]
mirrors forall a b. (a -> b) -> a -> b
$ \Repository down
r -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
requiresBootstrap forall a b. (a -> b) -> a -> b
$ forall a.
((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO a)
-> IO a
Sec.uncheckClientErrors forall a b. (a -> b) -> a -> b
$
forall (down :: * -> *).
(Throws SomeRemoteError, Throws VerificationError) =>
Repository down -> [KeyId] -> KeyThreshold -> IO ()
Sec.bootstrap Repository down
r
(forall a b. (a -> b) -> [a] -> [b]
map FilePath -> KeyId
Sec.KeyId [FilePath]
remoteRepoRootKeys)
(Int54 -> KeyThreshold
Sec.KeyThreshold (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
remoteRepoKeyThreshold))
SecureRepo -> IO a
callback forall a b. (a -> b) -> a -> b
$ forall (down :: * -> *). Repository down -> SecureRepo
SecureRepo Repository down
r
where
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 forall a. Eq a => a -> a -> Bool
== FilePath
"file:" = do
Path Absolute
dir <- FsPath -> IO (Path Absolute)
Sec.makeAbsolute forall a b. (a -> b) -> a -> b
$ FilePath -> FsPath
Sec.fromFilePath (URI -> FilePath
uriPath URI
remoteRepoURI)
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
forall (down :: * -> *). Repository down -> IO a
callback
withRepo [URI]
mirrors forall (down :: * -> *). Repository down -> IO a
callback =
forall a.
HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
Sec.Remote.withRepository HttpLib
httpLib
(URI
remoteRepoURIforall a. a -> [a] -> [a]
:[URI]
mirrors)
RepoOpts
Sec.Remote.defaultRepoOpts
Cache
cache
RepoLayout
Sec.hackageRepoLayout
IndexLayout
Sec.hackageIndexLayout
LogMessage -> IO ()
logTUF
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 {
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 = forall root. Path Unrooted -> Path root
Sec.rootPath 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> FilePath
Sec.pretty