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 Control.Exception (try)
   8 import Distribution.Client.Compat.Prelude
   9 import Distribution.Simple.Utils
  10 import Network.URI (URI (..), URIAuth (..), parseURI)
  11 import Prelude ()
  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 queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]
  46
  47 #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
  48 -- use @resolv@ package for performing DNS queries
  49 queryBootstrapMirrors verbosity repoUri
  50   | Just auth <- uriAuthority repoUri = do
  51          let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth))
  52
  53          mirrors' <- try $ do
  54                   txts <- queryTXT mirrorsDnsName
  55                   evaluate (force $ extractMirrors (map snd txts))
  56
  57          mirrors <- case mirrors' of
  58              Left e -> do
  59                  warn verbosity ("Caught exception during _mirrors lookup:"++
  60                                  displayException (e :: SomeException))
  61                  return []
  62              Right v -> return v
  63
  64          if null mirrors
  65          then warn verbosity ("No mirrors found for " ++ show repoUri)
  66          else do info verbosity ("located " ++ show (length mirrors) ++
  67                                  " mirrors for " ++ show repoUri ++ " :")
  68                  for_ mirrors $ \url -> info verbosity ("- " ++ show url)
  69
  70          return mirrors
  71
  72   | otherwise = return []
  73
  74 -- | Extract list of mirrors from 'queryTXT' result
  75 extractMirrors :: [[CharStr]] -> [URI]
  76 extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals
  77   where
  78     vals = [ (kn,v) | CharStr e <- concat txtChunks
  79                     , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)]
  80                     , Just kn <- [isUrlBase k]
  81                     ]
  82
  83 ----------------------------------------------------------------------------
  84 #else /* !defined(MIN_VERSION_resolv) */
  85 -- use external method via @nslookup@
  86 queryBootstrapMirrors verbosity repoUri
  87   | Just auth <- uriAuthority repoUri = do
  88         progdb <- configureAllKnownPrograms verbosity $
  89                   addKnownProgram nslookupProg emptyProgramDb
  90
  91         case lookupProgram nslookupProg progdb of
  92           Nothing -> do
  93               warn verbosity "'nslookup' tool missing - can't locate mirrors"
  94               return []
  95
  96           Just nslookup -> do
  97               let mirrorsDnsName = "_mirrors." ++ uriRegName auth
  98
  99               mirrors' <- try $ do
 100                   out <- getProgramInvocationOutput verbosity $
 101                          programInvocation nslookup ["-query=TXT", mirrorsDnsName]
 102                   evaluate (force $ extractMirrors mirrorsDnsName out)
 103
 104               mirrors <- case mirrors' of
 105                 Left e -> do
 106                     warn verbosity ("Caught exception during _mirrors lookup:"++
 107                                     displayException (e :: SomeException))
 108                     return []
 109                 Right v -> return v
 110
 111               if null mirrors
 112               then warn verbosity ("No mirrors found for " ++ show repoUri)
 113               else do info verbosity ("located " ++ show (length mirrors) ++
 114                                       " mirrors for " ++ show repoUri ++ " :")
 115                       for_ mirrors $ \url -> info verbosity ("- " ++ show url)
 116
 117               return mirrors
 118
 119   | otherwise = return []
 120   where
 121     nslookupProg = simpleProgram "nslookup"
 122
 123 -- | Extract list of mirrors from @nslookup -query=TXT@ output.
 124 extractMirrors :: String -> String -> [URI]
 125 extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals
 126   where
 127     vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0
 128                     , h == hostname
 129                     , e <- ents
 130                     , Just (k,v) <- [splitRfc1464 e]
 131                     , Just kn <- [isUrlBase k]
 132                     ]
 133
 134 -- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly
 135 parseNsLookupTxt :: String -> Maybe [(String,[String])]
 136 parseNsLookupTxt = go0 [] []
 137   where
 138     -- approximate grammar:
 139     -- <entries> := { <entry> }
 140     -- (<entry> starts at begin of line, but may span multiple lines)
 141     -- <entry> := ^ <hostname> TAB "text =" { <qstring> }
 142     -- <qstring> := string enclosed by '"'s ('\' and '"' are \-escaped)
 143
 144     -- scan for ^ <word> <TAB> "text ="
 145     go0 []  _  []                                = Nothing
 146     go0 res _  []                                = Just (reverse res)
 147     go0 res _  ('\n':xs)                         = go0 res [] xs
 148     go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs)
 149     go0 res lw (x:xs)                            = go0 res (x:lw) xs
 150
 151     -- collect at least one <qstring>
 152     go1 res lw qs ('"':xs) = case qstr "" xs of
 153       Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')
 154       Nothing       -> Nothing -- bad quoting
 155     go1 _   _  [] _  = Nothing -- missing qstring
 156     go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs
 157
 158     qstr _   ('\n':_) = Nothing -- We don't support unquoted LFs
 159     qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs
 160     qstr acc ('\\':'"':cs)  = qstr ('"':acc) cs
 161     qstr acc ('"':cs) = Just (reverse acc, cs)
 162     qstr acc (c:cs)   = qstr (c:acc) cs
 163     qstr _   []       = Nothing
 164
 165 #endif
 166 ----------------------------------------------------------------------------
 167
 168 -- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data
 169 isUrlBase :: String -> Maybe Int
 170 isUrlBase s
 171   | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns
 172   | otherwise = Nothing
 173   where
 174     ns = take (length s - 8) s
 175
 176 -- | Split a TXT string into key and value according to RFC1464.
 177 -- Returns 'Nothing' if parsing fails.
 178 splitRfc1464 :: String -> Maybe (String, String)
 179 splitRfc1464 = go ""
 180   where
 181     go _ [] = Nothing
 182     go acc ('`' : c : cs) = go (c : acc) cs
 183     go acc ('=' : cs) = go2 (reverse acc) "" cs
 184     go acc (c : cs)
 185       | isSpace c = go acc cs
 186       | otherwise = go (c : acc) cs
 187
 188     go2 k acc [] = Just (k, reverse acc)
 189     go2 _ _ ['`'] = Nothing
 190     go2 k acc ('`' : c : cs) = go2 k (c : acc) cs
 191     go2 k acc (c : cs) = go2 k (c : acc) cs