From 176ff869240bee0cc17aab2d6b3da2d9d95c5d0c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Fri, 7 Oct 2016 22:53:39 +0200 Subject: [PATCH] Implement DNS-based mirror bootstrap protocol This way `cabal` can bootstrap secure repos even if the primary Hackage instance is currently unreachable, as long as there's at least one reachable and working secure mirror available. NB: This new code-path is only used for the initial bootstrap. Once the repository cache has been bootstrapped, its `mirrors.json` meta-data is used instead. See also https://github.com/well-typed/hackage-security/issues/171 --- .../Distribution/Client/GlobalFlags.hs | 26 +++- .../Distribution/Client/Security/DNS.hs | 146 ++++++++++++++++++ cabal-install/cabal-install.cabal | 1 + 3 files changed, 166 insertions(+), 7 deletions(-) create mode 100644 cabal-install/Distribution/Client/Security/DNS.hs diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index d4b5c6f1242..ee0f4d9a938 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -36,7 +36,7 @@ import Control.Exception import System.FilePath ( () ) import Network.URI - ( uriScheme, uriPath ) + ( URI, uriScheme, uriPath ) import qualified Data.Map as Map import qualified Hackage.Security.Client as Sec @@ -46,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 @@ -215,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) @@ -224,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 @@ -233,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 diff --git a/cabal-install/Distribution/Client/Security/DNS.hs b/cabal-install/Distribution/Client/Security/DNS.hs new file mode 100644 index 00000000000..d55446f587f --- /dev/null +++ b/cabal-install/Distribution/Client/Security/DNS.hs @@ -0,0 +1,146 @@ +module Distribution.Client.Security.DNS + ( queryBootstrapMirrors + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Control.Monad +import Control.DeepSeq (force) +import Control.Exception +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: + -- := { } + -- ( starts at begin of line, but may span multiple lines) + -- := ^ TAB "text =" { } + -- := string enclosed by '"'s ('\' and '"' are \-escaped) + + -- scan for ^ "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 + 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 diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 29457db4c1d..0ab517c715a 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -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