Commit 34eecf48 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by GitHub
Browse files

Merge pull request #3947 from hvr/pr/mirrors-bootstrap

Implement DNS-based mirror bootstrap protocol
parents 879ffba4 ae24c5c6
......@@ -4,6 +4,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.GlobalFlags (
GlobalFlags(..)
, defaultGlobalFlags
......@@ -12,9 +13,11 @@ module Distribution.Client.GlobalFlags (
, withRepoContext'
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Types
( Repo(..), RemoteRepo(..) )
import Distribution.Compat.Semigroup
import Distribution.Simple.Setup
( Flag(..), fromFlag, flagToMaybe )
import Distribution.Utils.NubList
......@@ -26,22 +29,15 @@ import Distribution.Verbosity
import Distribution.Simple.Utils
( info )
import Data.Maybe
( fromMaybe )
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 )
( URI, uriScheme, uriPath )
import qualified Data.Map as Map
import GHC.Generics ( Generic )
import qualified Hackage.Security.Client as Sec
import qualified Hackage.Security.Util.Path as Sec
......@@ -50,6 +46,7 @@ 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
-- ------------------------------------------------------------
-- * Global flags
......@@ -219,8 +216,19 @@ initSecureRepo :: Verbosity
-> (SecureRepo -> IO a) -- ^ Callback
-> IO a
initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do
withRepo $ \r -> do
requiresBootstrap <- Sec.requiresBootstrap r
requiresBootstrap <- withRepo [] Sec.requiresBootstrap
mirrors <- if requiresBootstrap
then do
info verbosity $ "Trying to locate mirrors via DNS for " ++
"initial bootstrap of secure " ++
"repository '" ++ show remoteRepoURI ++
"' ..."
Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI
else pure []
withRepo mirrors $ \r -> do
when requiresBootstrap $ Sec.uncheckClientErrors $
Sec.bootstrap r
(map Sec.KeyId remoteRepoRootKeys)
......@@ -228,8 +236,8 @@ initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do
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
withRepo :: [URI] -> (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
......@@ -237,9 +245,9 @@ initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do
Sec.hackageIndexLayout
logTUF
callback
withRepo callback =
withRepo mirrors callback =
Sec.Remote.withRepository httpLib
[remoteRepoURI]
(remoteRepoURI:mirrors)
Sec.Remote.defaultRepoOpts
cache
Sec.hackageRepoLayout
......
module Distribution.Client.Security.DNS
( queryBootstrapMirrors
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Control.Monad
import Control.DeepSeq (force)
import Control.Exception (SomeException, evaluate, try)
import Network.URI (URI(..), URIAuth(..), parseURI)
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Simple.Program.Db
( emptyProgramDb, addKnownProgram
, configureAllKnownPrograms, lookupProgram )
import Distribution.Simple.Program
( simpleProgram
, programInvocation
, getProgramInvocationOutput )
import Distribution.Compat.Exception (displayException)
-- | Try to lookup RFC1464-encoded mirror urls for a Hackage
-- repository url by performing a DNS TXT lookup on the
-- @_mirrors.@-prefixed URL hostname.
--
-- Example: for @http://hackage.haskell.org/@
-- perform a DNS TXT query for the hostname
-- @_mirrors.hackage.haskell.org@ which may look like e.g.
--
-- > _mirrors.hackage.haskell.org. 300 IN TXT
-- > "0.urlbase=http://hackage.fpcomplete.com/"
-- > "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"
--
-- NB: hackage-security doesn't require DNS lookups being trustworthy,
-- as the trust is established via the cryptographically signed TUF
-- meta-data that is retrieved from the resolved Hackage repository.
-- Moreover, we already have to protect against a compromised
-- @hackage.haskell.org@ DNS entry, so an the additional
-- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't
-- constitute a significant new attack vector anyway.
--
queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]
queryBootstrapMirrors verbosity repoUri
| Just auth <- uriAuthority repoUri = do
progdb <- configureAllKnownPrograms verbosity $
addKnownProgram nslookupProg emptyProgramDb
case lookupProgram nslookupProg progdb of
Nothing -> do
warn verbosity "'nslookup' tool missing - can't locate mirrors"
return []
Just nslookup -> do
let mirrorsDnsName = "_mirrors." ++ uriRegName auth
mirrors' <- try $ do
out <- getProgramInvocationOutput verbosity $
programInvocation nslookup ["-query=TXT", mirrorsDnsName]
evaluate (force $ extractMirrors mirrorsDnsName out)
mirrors <- case mirrors' of
Left e -> do
warn verbosity ("Caught exception during _mirrors lookup:"++
displayException (e :: SomeException))
return []
Right v -> return v
if null mirrors
then warn verbosity ("No mirrors found for " ++ show repoUri)
else do info verbosity ("located " ++ show (length mirrors) ++
" mirrors for " ++ show repoUri ++ " :")
forM_ mirrors $ \url -> info verbosity ("- " ++ show url)
return mirrors
| otherwise = return []
where
nslookupProg = simpleProgram "nslookup"
-- | Extract list of mirrors from @nslookup -query=TXT@ output.
extractMirrors :: String -> String -> [URI]
extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals
where
vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0
, h == hostname
, e <- ents
, Just (k,v) <- [splitRfc1464 e]
, Just kn <- [isUrlBase k]
]
isUrlBase :: String -> Maybe Int
isUrlBase s
| isSuffixOf ".urlbase" s, not (null ns), all isDigit ns = readMaybe ns
| otherwise = Nothing
where
ns = take (length s - 8) s
-- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly
parseNsLookupTxt :: String -> Maybe [(String,[String])]
parseNsLookupTxt = go0 [] []
where
-- approximate grammar:
-- <entries> := { <entry> }
-- (<entry> starts at begin of line, but may span multiple lines)
-- <entry> := ^ <hostname> TAB "text =" { <qstring> }
-- <qstring> := string enclosed by '"'s ('\' and '"' are \-escaped)
-- scan for ^ <word> <TAB> "text ="
go0 [] _ [] = Nothing
go0 res _ [] = Just (reverse res)
go0 res _ ('\n':xs) = go0 res [] xs
go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs)
go0 res lw (x:xs) = go0 res (x:lw) xs
-- collect at least one <qstring>
go1 res lw qs ('"':xs) = case qstr "" xs of
Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')
Nothing -> Nothing -- bad quoting
go1 _ _ [] _ = Nothing -- missing qstring
go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs
qstr _ ('\n':_) = Nothing -- We don't support unquoted LFs
qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs
qstr acc ('\\':'"':cs) = qstr ('"':acc) cs
qstr acc ('"':cs) = Just (reverse acc, cs)
qstr acc (c:cs) = qstr (c:acc) cs
qstr _ [] = Nothing
-- | Split a TXT string into key and value according to RFC1464.
-- Returns 'Nothing' if parsing fails.
splitRfc1464 :: String -> Maybe (String,String)
splitRfc1464 = go ""
where
go _ [] = Nothing
go acc ('`':c:cs) = go (c:acc) cs
go acc ('=':cs) = go2 (reverse acc) "" cs
go acc (c:cs)
| isSpace c = go acc cs
| otherwise = go (c:acc) cs
go2 k acc [] = Just (k,reverse acc)
go2 _ _ ['`'] = Nothing
go2 k acc ('`':c:cs) = go2 k (c:acc) cs
go2 k acc (c:cs) = go2 k (c:acc) cs
......@@ -318,6 +318,7 @@ executable cabal
Distribution.Client.Sandbox.Timestamp
Distribution.Client.Sandbox.Types
Distribution.Client.SavedFlags
Distribution.Client.Security.DNS
Distribution.Client.Security.HTTP
Distribution.Client.Setup
Distribution.Client.SetupWrapper
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment