Implement DNS-based mirror bootstrap protocol

cabal-install/Distribution/Client/GlobalFlags.hs

@@ -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,27 +216,38 @@ 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)
           (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
+    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
                                Sec.hackageRepoLayout
                                Sec.hackageIndexLayout
                                logTUF
                                callback
-    withRepo callback =
+    withRepo mirrors callback =
       Sec.Remote.withRepository httpLib
-                                [remoteRepoURI]
+                                (remoteRepoURI:mirrors)
                                 Sec.Remote.defaultRepoOpts
                                 cache
                                 Sec.hackageRepoLayout

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 (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

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