cabal-install/src/Distribution/Client/Security/DNS.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 module Distribution.Client.Security.DNS
   4     ( queryBootstrapMirrors
   5     ) where
   6
   7 import Prelude ()
   8 import Distribution.Client.Compat.Prelude
   9 import Network.URI (URI(..), URIAuth(..), parseURI)
  10 import Control.Exception (try)
  11 import Distribution.Simple.Utils
  12
  13 #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
  14 import Network.DNS (queryTXT, Name(..), CharStr(..))
  15 import qualified Data.ByteString.Char8 as BS.Char8
  16 #else
  17 import Distribution.Simple.Program.Db
  18          ( emptyProgramDb, addKnownProgram
  19          , configureAllKnownPrograms, lookupProgram )
  20 import Distribution.Simple.Program
  21          ( simpleProgram
  22          , programInvocation
  23          , getProgramInvocationOutput )
  24 #endif
  25
  26 -- | Try to lookup RFC1464-encoded mirror urls for a Hackage
  27 -- repository url by performing a DNS TXT lookup on the
  28 -- @_mirrors.@-prefixed URL hostname.
  29 --
  30 -- Example: for @http://hackage.haskell.org/@
  31 -- perform a DNS TXT query for the hostname
  32 -- @_mirrors.hackage.haskell.org@ which may look like e.g.
  33 --
  34 -- > _mirrors.hackage.haskell.org. 300 IN TXT
  35 -- >    "0.urlbase=http://hackage.fpcomplete.com/"
  36 -- >    "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"
  37 --
  38 -- NB: hackage-security doesn't require DNS lookups being trustworthy,
  39 -- as the trust is established via the cryptographically signed TUF
  40 -- meta-data that is retrieved from the resolved Hackage repository.
  41 -- Moreover, we already have to protect against a compromised
  42 -- @hackage.haskell.org@ DNS entry, so an the additional
  43 -- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't
  44 -- constitute a significant new attack vector anyway.
  45 --
  46 queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]
  47
  48 #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
  49 -- use @resolv@ package for performing DNS queries
  50 queryBootstrapMirrors verbosity repoUri
  51   | Just auth <- uriAuthority repoUri = do
  52          let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth))
  53
  54          mirrors' <- try $ do
  55                   txts <- queryTXT mirrorsDnsName
  56                   evaluate (force $ extractMirrors (map snd txts))
  57
  58          mirrors <- case mirrors' of
  59              Left e -> do
  60                  warn verbosity ("Caught exception during _mirrors lookup:"++
  61                                  displayException (e :: SomeException))
  62                  return []
  63              Right v -> return v
  64
  65          if null mirrors
  66          then warn verbosity ("No mirrors found for " ++ show repoUri)
  67          else do info verbosity ("located " ++ show (length mirrors) ++
  68                                  " mirrors for " ++ show repoUri ++ " :")
  69                  for_ mirrors $ \url -> info verbosity ("- " ++ show url)
  70
  71          return mirrors
  72
  73   | otherwise = return []
  74
  75 -- | Extract list of mirrors from 'queryTXT' result
  76 extractMirrors :: [[CharStr]] -> [URI]
  77 extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals
  78   where
  79     vals = [ (kn,v) | CharStr e <- concat txtChunks
  80                     , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)]
  81                     , Just kn <- [isUrlBase k]
  82                     ]
  83
  84 ----------------------------------------------------------------------------
  85 #else /* !defined(MIN_VERSION_resolv) */
  86 -- use external method via @nslookup@
  87 queryBootstrapMirrors verbosity repoUri
  88   | Just auth <- uriAuthority repoUri = do
  89         progdb <- configureAllKnownPrograms verbosity $
  90                   addKnownProgram nslookupProg emptyProgramDb
  91
  92         case lookupProgram nslookupProg progdb of
  93           Nothing -> do
  94               warn verbosity "'nslookup' tool missing - can't locate mirrors"
  95               return []
  96
  97           Just nslookup -> do
  98               let mirrorsDnsName = "_mirrors." ++ uriRegName auth
  99
 100               mirrors' <- try $ do
 101                   out <- getProgramInvocationOutput verbosity $
 102                          programInvocation nslookup ["-query=TXT", mirrorsDnsName]
 103                   evaluate (force $ extractMirrors mirrorsDnsName out)
 104
 105               mirrors <- case mirrors' of
 106                 Left e -> do
 107                     warn verbosity ("Caught exception during _mirrors lookup:"++
 108                                     displayException (e :: SomeException))
 109                     return []
 110                 Right v -> return v
 111
 112               if null mirrors
 113               then warn verbosity ("No mirrors found for " ++ show repoUri)
 114               else do info verbosity ("located " ++ show (length mirrors) ++
 115                                       " mirrors for " ++ show repoUri ++ " :")
 116                       for_ mirrors $ \url -> info verbosity ("- " ++ show url)
 117
 118               return mirrors
 119
 120   | otherwise = return []
 121   where
 122     nslookupProg = simpleProgram "nslookup"
 123
 124 -- | Extract list of mirrors from @nslookup -query=TXT@ output.
 125 extractMirrors :: String -> String -> [URI]
 126 extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals
 127   where
 128     vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0
 129                     , h == hostname
 130                     , e <- ents
 131                     , Just (k,v) <- [splitRfc1464 e]
 132                     , Just kn <- [isUrlBase k]
 133                     ]
 134
 135 -- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly
 136 parseNsLookupTxt :: String -> Maybe [(String,[String])]
 137 parseNsLookupTxt = go0 [] []
 138   where
 139     -- approximate grammar:
 140     -- <entries> := { <entry> }
 141     -- (<entry> starts at begin of line, but may span multiple lines)
 142     -- <entry> := ^ <hostname> TAB "text =" { <qstring> }
 143     -- <qstring> := string enclosed by '"'s ('\' and '"' are \-escaped)
 144
 145     -- scan for ^ <word> <TAB> "text ="
 146     go0 []  _  []                                = Nothing
 147     go0 res _  []                                = Just (reverse res)
 148     go0 res _  ('\n':xs)                         = go0 res [] xs
 149     go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs)
 150     go0 res lw (x:xs)                            = go0 res (x:lw) xs
 151
 152     -- collect at least one <qstring>
 153     go1 res lw qs ('"':xs) = case qstr "" xs of
 154       Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')
 155       Nothing       -> Nothing -- bad quoting
 156     go1 _   _  [] _  = Nothing -- missing qstring
 157     go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs
 158
 159     qstr _   ('\n':_) = Nothing -- We don't support unquoted LFs
 160     qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs
 161     qstr acc ('\\':'"':cs)  = qstr ('"':acc) cs
 162     qstr acc ('"':cs) = Just (reverse acc, cs)
 163     qstr acc (c:cs)   = qstr (c:acc) cs
 164     qstr _   []       = Nothing
 165
 166 #endif
 167 ----------------------------------------------------------------------------
 168
 169 -- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data
 170 isUrlBase :: String -> Maybe Int
 171 isUrlBase s
 172   | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns
 173   | otherwise = Nothing
 174   where
 175     ns = take (length s - 8) s
 176
 177 -- | Split a TXT string into key and value according to RFC1464.
 178 -- Returns 'Nothing' if parsing fails.
 179 splitRfc1464 :: String -> Maybe (String,String)
 180 splitRfc1464 = go ""
 181   where
 182     go _ [] = Nothing
 183     go acc ('`':c:cs) = go (c:acc) cs
 184     go acc ('=':cs)   = go2 (reverse acc) "" cs
 185     go acc (c:cs)
 186       | isSpace c = go acc cs
 187       | otherwise = go (c:acc) cs
 188
 189     go2 k acc [] = Just (k,reverse acc)
 190     go2 _ _   ['`'] = Nothing
 191     go2 k acc ('`':c:cs) = go2 k (c:acc) cs
 192     go2 k acc (c:cs) = go2 k (c:acc) cs