Commit 4d605156 authored by Edsko de Vries's avatar Edsko de Vries

Introduce secure repos

parent eab6c531
......@@ -72,7 +72,7 @@ import Distribution.ParseUtils
, ParseResult(..), PError(..), PWarning(..)
, locatedErrorMsg, showPWarning
, readFields, warning, lineNo
, simpleField, listField, boolField, spaceListField
, simpleField, listField, spaceListField
, parseFilePathQ, parseTokenQ )
import Distribution.Client.ParseUtils
( parseFields, ppFields, ppSection )
......@@ -488,7 +488,7 @@ defaultUserInstall = True
-- global installs on Windows but that no longer works on Windows Vista or 7.
defaultRemoteRepo :: RemoteRepo
defaultRemoteRepo = RemoteRepo name uri False [] 0 False
defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
where
name = "hackage.haskell.org"
uri = URI "http:" (Just (URIAuth "" name "")) "/" "" ""
......@@ -497,11 +497,6 @@ defaultRemoteRepo = RemoteRepo name uri False [] 0 False
-- but new config files can use the new url (without the /packages/archive)
-- and avoid having to do a http redirect
-- TODO: Once we make secure access opt-out rather than opt-in, we could
-- Use this as a source for crypto credentials when finding old remote-repo
-- entries that match repo name and url (not only be used for generating
-- fresh config files).
-- For the default repo we know extra information, fill this in.
--
-- We need this because the 'defaultRemoteRepo' above is only used for the
......@@ -509,11 +504,15 @@ defaultRemoteRepo = RemoteRepo name uri False [] 0 False
-- we might have only have older info. This lets us fill that in even for old
-- config files.
--
-- TODO: Once we migrate from opt-in to opt-out security for the central
-- Hackage repository, we should enable security and specify keys and threshold
-- for repositories that have their security setting as 'Nothing' (default).
addInfoForKnownRepos :: RemoteRepo -> RemoteRepo
addInfoForKnownRepos repo@RemoteRepo{ remoteRepoName = "hackage.haskell.org" } =
tryHttps $ if isOldHackageURI (remoteRepoURI repo) then defaultRemoteRepo else repo
tryHttps
$ if isOldHackageURI (remoteRepoURI repo) then defaultRemoteRepo else repo
where
tryHttps r = r { remoteRepoShouldTryHttps = True }
tryHttps r = r { remoteRepoShouldTryHttps = True }
addInfoForKnownRepos other = other
--
......@@ -844,7 +843,7 @@ parseConfig src initial = \str -> do
}
where
isKnownSection (ParseUtils.Section _ "remote-repo" _ _) = True
isKnownSection (ParseUtils.Section _ "repository" _ _) = True
isKnownSection (ParseUtils.F _ "remote-repo" _) = True
isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
......@@ -856,12 +855,12 @@ parseConfig src initial = \str -> do
++ deprecatedFieldDescriptions) initial
parseSections (rs, h, u, g, p, a)
(ParseUtils.Section _ "remote-repo" name fs) = do
(ParseUtils.Section _ "repository" name fs) = do
r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs
when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $
warning $ "'key-threshold' for repository " ++ show (remoteRepoName r')
++ " higher than number of keys"
when (not (null (remoteRepoRootKeys r')) && not (remoteRepoSecure r')) $
when (not (null (remoteRepoRootKeys r')) && remoteRepoSecure r' /= Just True) $
warning $ "'root-keys' for repository " ++ show (remoteRepoName r')
++ " non-empty, but 'secure' not set to True."
return (r':rs, h, u, g, p, a)
......@@ -950,7 +949,7 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions
ppRemoteRepoSection :: RemoteRepo -> Doc
ppRemoteRepoSection vals = ppSection "remote-repo" (remoteRepoName vals)
ppRemoteRepoSection vals = ppSection "repository" (remoteRepoName vals)
remoteRepoFields Nothing vals
remoteRepoFields :: [FieldDescr RemoteRepo]
......@@ -958,13 +957,14 @@ remoteRepoFields =
[ simpleField "url"
(text . show) (parseTokenQ >>= parseURI')
remoteRepoURI (\x repo -> repo { remoteRepoURI = x })
, boolField "secure"
, simpleField "secure"
showSecure (parseTokenQ >>= parseSecure)
remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x })
, listField "root-keys"
text parseTokenQ
remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x })
, simpleField "key-threshold"
(text . show) (parseTokenQ >>= parseInt)
showThreshold (parseTokenQ >>= parseInt)
remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x })
]
where
......@@ -980,6 +980,22 @@ remoteRepoFields =
[(n, _)] -> return n
_ -> fail $ "remote-remo: could not parse int " ++ show intString
showSecure Nothing = mempty -- default 'secure' setting
showSecure (Just True) = text "True" -- user explicitly enabled it
showSecure (Just False) = text "False" -- user explicitly disabled it
parseSecure "True" = return $ Just True
parseSecure "False" = return $ Just False
parseSecure str = fail $ "remote-repo: could not parse bool " ++ show str
-- If the key-threshold is set to 0, we omit it as this is the default
-- and it looks odd to have a value for key-threshold but not for 'secure'
-- (note that an empty list of keys is already omitted by default, since
-- that is what we do for all list fields)
showThreshold 0 = mempty
showThreshold t = text (show t)
-- | Fields for the 'haddock' section.
haddockFlagsFields :: [FieldDescr HaddockFlags]
haddockFlagsFields = [ field
......
......@@ -54,6 +54,8 @@ import qualified System.FilePath.Posix as FilePath.Posix
import Network.URI
( URI(uriPath) )
import qualified Hackage.Security.Client as Sec
-- ------------------------------------------------------------
-- * Actually fetch things
-- ------------------------------------------------------------
......@@ -148,6 +150,15 @@ fetchRepoTarball verbosity repoCtxt repo pkgid = do
_ <- downloadURI transport verbosity uri path
return path
RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do
let dir = packageDir repo pkgid
path = packageFile repo pkgid
createDirectoryIfMissing True dir
Sec.uncheckClientErrors $ do
info verbosity ("writing " ++ path)
Sec.downloadPackage' rep pkgid path
return path
-- | Downloads an index file to [config-dir/packages/serv-id].
--
downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.GlobalFlags (
GlobalFlags(..)
, defaultGlobalFlags
......@@ -16,17 +21,36 @@ import Distribution.Client.HttpUtils
( HttpTransport, configureTransport )
import Distribution.Verbosity
( Verbosity )
import Distribution.Simple.Utils
( info )
import Control.Concurrent
( MVar, newMVar, modifyMVar )
import Control.Exception
( throwIO )
import Control.Monad
( when )
import System.FilePath
( (</>) )
import Network.URI
( uriScheme, uriPath )
import Data.Map
( Map )
import qualified Data.Map as Map
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
( Monoid(..) )
#endif
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
-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------
......@@ -122,22 +146,44 @@ data RepoContext = RepoContext {
-- initialization on _every_ invocation (eg @cabal build@) is undesirable.
, repoContextGetTransport :: IO HttpTransport
-- | Get the (initialized) secure repo
--
-- (the 'Repo' type itself is stateless and must remain so, because it
-- must be serializable)
, repoContextWithSecureRepo :: forall a.
Repo
-> (forall down. Sec.Repository down -> IO a)
-> IO a
-- | Should we ignore expiry times (when checking security)?
, 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 callback = do
withRepoContext verbosity globalFlags = \callback -> do
transportRef <- newMVar Nothing
callback RepoContext {
repoContextRepos = remoteRepos ++ localRepos
, repoContextGetTransport = getTransport transportRef
, repoContextIgnoreExpiry = fromFlagOrDefault False
(globalIgnoreExpiry globalFlags)
}
let httpLib = Sec.HTTP.transportAdapter
verbosity
(getTransport transportRef)
initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' ->
callback RepoContext {
repoContextRepos = allRemoteRepos ++ localRepos
, repoContextGetTransport = getTransport transportRef
, repoContextWithSecureRepo = withSecureRepo secureRepos'
, repoContextIgnoreExpiry = fromFlagOrDefault False
(globalIgnoreExpiry globalFlags)
}
where
remoteRepos =
[ RepoRemote remote cacheDir
secureRemoteRepos =
[ (remote, cacheDir)
| RepoSecure remote cacheDir <- allRemoteRepos ]
allRemoteRepos =
[ case remoteRepoSecure remote of
Just True -> RepoSecure remote cacheDir
_otherwise -> RepoRemote remote cacheDir
| remote <- fromNubList $ globalRemoteRepos globalFlags
, let cacheDir = fromFlag (globalCacheDir globalFlags)
</> remoteRepoName remote ]
......@@ -154,3 +200,82 @@ withRepoContext verbosity globalFlags callback = do
verbosity
(flagToMaybe (globalHttpTransport globalFlags))
return (Just transport, transport)
withSecureRepo :: Map Repo SecureRepo
-> Repo
-> (forall down. Sec.Repository down -> IO a)
-> IO a
withSecureRepo secureRepos repo callback =
case Map.lookup repo secureRepos of
Just (SecureRepo secureRepo) -> callback secureRepo
Nothing -> throwIO $ userError "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 repos callback = go Map.empty repos
where
go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
go !acc [] = callback acc
go !acc ((r,cacheDir):rs) = do
cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir
initSecureRepo verbosity httpLib r cachePath $ \r' ->
go (Map.insert (RepoSecure r cacheDir) r' acc) 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{..} cachePath = \callback -> do
withRepo $ \r -> do
requiresBootstrap <- Sec.requiresBootstrap r
when requiresBootstrap $ Sec.uncheckClientErrors $
Sec.bootstrap r
(map Sec.KeyId remoteRepoRootKeys)
(Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold))
callback $ SecureRepo r
where
-- Initialize local or remote repo depending on the URI
withRepo :: (forall down. Sec.Repository down -> IO a) -> IO a
withRepo callback | uriScheme remoteRepoURI == "file:" = do
dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)
Sec.Local.withRepository dir
cache
Sec.hackageRepoLayout
Sec.hackageIndexLayout
logTUF
callback
withRepo callback =
Sec.Remote.withRepository httpLib
[remoteRepoURI]
Sec.Remote.defaultRepoOpts
cache
Sec.hackageRepoLayout
Sec.hackageIndexLayout
logTUF
callback
cache :: Sec.Cache
cache = Sec.Cache {
cacheRoot = cachePath
, cacheLayout = Sec.cabalCacheLayout
}
-- 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 = info verbosity . Sec.pretty
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.IndexUtils
......@@ -92,6 +93,8 @@ import System.IO
import System.IO.Unsafe (unsafeInterleaveIO)
import System.IO.Error (isDoesNotExistError)
import qualified Hackage.Security.Client as Sec
import qualified Hackage.Security.Util.Some as Sec
-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
getInstalledPackages :: Verbosity -> Compiler
......@@ -174,10 +177,9 @@ readRepoIndex verbosity repoCtxt repo =
handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
then do
case repo of
RepoRemote{..} -> warn verbosity $
"The package list for '" ++ remoteRepoName repoRemote
++ "' does not exist. Run 'cabal update' to download it."
RepoLocal{..} -> warn verbosity $
RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote
RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote
RepoLocal{..} -> warn verbosity $
"The package list for the local repo '" ++ repoLocalDir
++ "' is missing. The repo is invalid."
return mempty
......@@ -186,12 +188,17 @@ readRepoIndex verbosity repoCtxt repo =
isOldThreshold = 15 --days
warnIfIndexIsOld dt = do
when (dt >= isOldThreshold) $ case repo of
RepoRemote{..} -> warn verbosity $
"The package list for '" ++ remoteRepoName repoRemote
++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
++ "'cabal update' to get the latest list of available packages."
RepoLocal{..} -> return ()
RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
RepoLocal{..} -> return ()
errMissingPackageList repoRemote =
"The package list for '" ++ remoteRepoName repoRemote
++ "' does not exist. Run 'cabal update' to download it."
errOutdatedPackageList repoRemote dt =
"The package list for '" ++ remoteRepoName repoRemote
++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
++ "'cabal update' to get the latest list of available packages."
-- | Return the age of the index file in days (as a Double).
getIndexFileAge :: Repo -> IO Double
......@@ -389,7 +396,37 @@ updatePackageIndexCacheFile verbosity index = do
-- callback; when the callback is terminated the file handle to the index will
-- be closed and further attempts to read from the list will result in (pure)
-- I/O exceptions.
--
-- In the construction of the index for a secure repo we take advantage of the
-- index built by the @hackage-security@ library to avoid reading the @.tar@
-- file as much as possible (we need to read it only to extract preferred
-- versions). This helps performance, but is also required for correctness:
-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions
-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);
-- by reading the already-built cache from the security library we will be sure
-- to only read the latest versions of all files.
--
-- TODO: It would be nicer if we actually incrementally updated @cabal@'s
-- cache, rather than reconstruct it from zero on each update. However, this
-- would require a change in the cache format.
withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a
withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =
repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
let mk :: (Sec.DirectoryEntry, fp, Maybe (Sec.Some Sec.IndexFile))
-> IO [IndexCacheEntry]
mk (_, _fp, Nothing) =
return [] -- skip unrecognized file
mk (_, _fp, Just (Sec.Some (Sec.IndexPkgMetadata _pkgId))) =
return [] -- skip metadata
mk (dirEntry, _fp, Just (Sec.Some (Sec.IndexPkgCabal pkgId))) = do
let blockNo = fromIntegral (Sec.directoryEntryBlockNo dirEntry)
return [CachePackageId pkgId blockNo]
mk (dirEntry, _fp, Just (Sec.Some file@(Sec.IndexPkgPrefs _pkgName))) = do
content <- Sec.indexEntryContent `fmap` indexLookupFileEntry dirEntry file
return $ map CachePreference (parsePreferredVersions content)
entriess <- lazySequence $ map mk (Sec.directoryEntries indexDirectory)
callback $ concat entriess
withIndexEntries index callback = do
withFile (indexFile index) ReadMode $ \h -> do
bs <- maybeDecompress `fmap` BS.hGetContents h
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'
module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where
-- stdlibs
import Control.Exception
( Exception(..), IOException )
import Data.List
( intercalate )
import Data.Typeable
( Typeable )
import System.Directory
( getTemporaryDirectory )
import Network.URI
( URI )
import qualified Data.ByteString.Lazy as BS.L
import qualified Network.HTTP as HTTP
-- Cabal/cabal-install
import Distribution.Verbosity
( Verbosity )
import Distribution.Client.HttpUtils
( HttpTransport(..), HttpCode )
import Distribution.Client.Utils
( withTempFileName )
-- hackage-security
import Hackage.Security.Client
import Hackage.Security.Client.Repository.HttpLib
import Hackage.Security.Util.Checked
import Hackage.Security.Util.Pretty
import qualified Hackage.Security.Util.Lens as Lens
{-------------------------------------------------------------------------------
'HttpLib' implementation
-------------------------------------------------------------------------------}
-- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport'
--
-- NOTE: The match between these two APIs is currently not perfect:
--
-- * We don't get any response headers back from the 'HttpTransport', so we
-- don't know if the server supports range requests. For now we optimistically
-- assume that it does.
-- * The 'HttpTransport' wants to know where to place the resulting file,
-- whereas the 'HttpLib' expects an 'IO' action which streams the download;
-- the security library then makes sure that the file gets written to a
-- location which is suitable (in particular, to a temporary file in the
-- directory where the file needs to end up, so that it can "finalize" the
-- file simply by doing 'renameFile'). Right now we write the file to a
-- temporary file in the system temp directory here and then read it again
-- to pass it to the security library; this is a problem for two reasons: it
-- is a source of inefficiency; and it means that the security library cannot
-- insist on a minimum download rate (potential security attack).
-- Fixing it however would require changing the 'HttpTransport'.
transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib
transportAdapter verbosity getTransport = HttpLib{
httpGet = \headers uri callback -> do
transport <- getTransport
get verbosity transport headers uri callback
, httpGetRange = \headers uri range callback -> do
transport <- getTransport
getRange verbosity transport headers uri range callback
}
get :: Throws SomeRemoteError
=> Verbosity
-> HttpTransport
-> [HttpRequestHeader] -> URI
-> ([HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get verbosity transport reqHeaders uri callback = wrapCustomEx $ do
get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->
case code of
200 -> callback respHeaders br
_ -> throwChecked $ UnexpectedResponse uri code
getRange :: Throws SomeRemoteError
=> Verbosity
-> HttpTransport
-> [HttpRequestHeader] -> URI -> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do
get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->
case code of
200 -> callback HttpStatus200OK respHeaders br
206 -> callback HttpStatus206PartialContent respHeaders br
_ -> throwChecked $ UnexpectedResponse uri code
-- | Internal generalization of 'get' and 'getRange'
get' :: Verbosity
-> HttpTransport
-> [HttpRequestHeader] -> URI -> Maybe (Int, Int)
-> (HttpCode -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
get' verbosity transport reqHeaders uri mRange callback = do
tempDir <- getTemporaryDirectory
withTempFileName tempDir "transportAdapterGet" $ \temp -> do
(code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'
br <- bodyReaderFromBS =<< BS.L.readFile temp
callback code [HttpResponseAcceptRangesBytes] br
where
reqHeaders' = mkReqHeaders reqHeaders mRange
{-------------------------------------------------------------------------------
Request headers
-------------------------------------------------------------------------------}
mkRangeHeader :: Int -> Int -> HTTP.Header
mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader
where
-- Content-Range header uses inclusive rather than exclusive bounds
-- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>
rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)
mkReqHeaders :: [HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]
mkReqHeaders reqHeaders mRange = concat [
tr [] reqHeaders
, [mkRangeHeader fr to | Just (fr, to) <- [mRange]]
]
where
tr :: [(HTTP.HeaderName, [String])] -> [HttpRequestHeader] -> [HTTP.Header]
tr acc [] =
concatMap finalize acc
tr acc (HttpRequestMaxAge0:os) =
tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os
tr acc (HttpRequestNoTransform:os) =
tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os
-- Some headers are comma-separated, others need multiple headers for
-- multiple options.
--
-- TODO: Right we we just comma-separate all of them.
finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]
finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))]
insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
insert x y = Lens.modify (Lens.lookupM x) (++ y)
{-------------------------------------------------------------------------------
Custom exceptions
-------------------------------------------------------------------------------}
data UnexpectedResponse = UnexpectedResponse URI Int
deriving (Typeable)
instance Pretty UnexpectedResponse where
pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code
++ "for " ++ show uri
#if MIN_VERSION_base(4,8,0)
deriving instance Show UnexpectedResponse
instance Exception UnexpectedResponse where displayException = pretty
#else
instance Show UnexpectedResponse where show = pretty
instance Exception UnexpectedResponse
#endif
wrapCustomEx :: ( ( Throws UnexpectedResponse
, Throws IOException
) => IO a)
-> (Throws SomeRemoteError => IO a)
wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse) -> go ex)
$ handleChecked (\(ex :: IOException) -> go ex)
$ act
where
go ex = throwChecked (SomeRemoteError ex)
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Setup
......@@ -2249,7 +2252,7 @@ parseRepo = do
return RemoteRepo {
remoteRepoName = name,
remoteRepoURI = uri,
remoteRepoSecure = False,
remoteRepoSecure = Nothing,
remoteRepoRootKeys = [],
remoteRepoKeyThreshold = 0,
remoteRepoShouldTryHttps = False
......
......@@ -214,8 +214,13 @@ data RemoteRepo =
remoteRepoName :: String,
remoteRepoURI :: URI,
-- | Enable secure access to Hackage?
remoteRepoSecure :: Bool,
-- | Enable secure access?
--
-- 'Nothing' here represents "whatever the default is"; this is important
-- to allow for a smooth transition from opt-in to opt-out security
-- (once we switch to opt-out, all access to the central Hackage
-- repository should be secure by default)