{-# LANGUAGE CPP #-}

module Distribution.Client.Security.DNS
    ( queryBootstrapMirrors
    ) where

import Prelude ()
import Distribution.Client.Compat.Prelude
import Network.URI (URI(..), URIAuth(..), parseURI)
import Control.Exception (try)
import Distribution.Simple.Utils

#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
import Network.DNS (queryTXT, Name(..), CharStr(..))
import qualified Data.ByteString.Char8 as BS.Char8
#else
import Distribution.Simple.Program.Db
         ( emptyProgramDb, addKnownProgram
         , configureAllKnownPrograms, lookupProgram )
import Distribution.Simple.Program
         ( simpleProgram
         , programInvocation
         , getProgramInvocationOutput )
#endif

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

#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
-- use @resolv@ package for performing DNS queries
queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]
queryBootstrapMirrors Verbosity
verbosity URI
repoUri
  | Just URIAuth
auth <- URI -> Maybe URIAuth
uriAuthority URI
repoUri = do
         let mirrorsDnsName :: Name
mirrorsDnsName = ByteString -> Name
Name (String -> ByteString
BS.Char8.pack (String
"_mirrors." forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriRegName URIAuth
auth))

         Either SomeException [URI]
mirrors' <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ do
                  [(TTL, [CharStr])]
txts <- Name -> IO [(TTL, [CharStr])]
queryTXT Name
mirrorsDnsName
                  forall a. a -> IO a
evaluate (forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ [[CharStr]] -> [URI]
extractMirrors (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TTL, [CharStr])]
txts))

         [URI]
mirrors <- case Either SomeException [URI]
mirrors' of
             Left SomeException
e -> do
                 Verbosity -> String -> IO ()
warn Verbosity
verbosity (String
"Caught exception during _mirrors lookup:"forall a. [a] -> [a] -> [a]
++
                                 forall e. Exception e => e -> String
displayException (SomeException
e :: SomeException))
                 forall (m :: * -> *) a. Monad m => a -> m a
return []
             Right [URI]
v -> forall (m :: * -> *) a. Monad m => a -> m a
return [URI]
v

         if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [URI]
mirrors
         then Verbosity -> String -> IO ()
warn Verbosity
verbosity (String
"No mirrors found for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
repoUri)
         else do Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"located " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [URI]
mirrors) forall a. [a] -> [a] -> [a]
++
                                 String
" mirrors for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
repoUri forall a. [a] -> [a] -> [a]
++ String
" :")
                 forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [URI]
mirrors forall a b. (a -> b) -> a -> b
$ \URI
url -> Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"- " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
url)

         forall (m :: * -> *) a. Monad m => a -> m a
return [URI]
mirrors

  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Extract list of mirrors from 'queryTXT' result
extractMirrors :: [[CharStr]] -> [URI]
extractMirrors :: [[CharStr]] -> [URI]
extractMirrors [[CharStr]]
txtChunks = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe URI
parseURI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ [(Int, String)]
vals
  where
    vals :: [(Int, String)]
vals = [ (Int
kn,String
v) | CharStr ByteString
e <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CharStr]]
txtChunks
                    , Just (String
k,String
v) <- [String -> Maybe (String, String)
splitRfc1464 (ByteString -> String
BS.Char8.unpack ByteString
e)]
                    , Just Int
kn <- [String -> Maybe Int
isUrlBase String
k]
                    ]

----------------------------------------------------------------------------
#else /* !defined(MIN_VERSION_resolv) */
-- use external method via @nslookup@
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 ++ " :")
                      for_ 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]
                    ]

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

#endif
----------------------------------------------------------------------------

-- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data
isUrlBase :: String -> Maybe Int
isUrlBase :: String -> Maybe Int
isUrlBase String
s
  | String
".urlbase" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
s, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ns), forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
ns = forall a. Read a => String -> Maybe a
readMaybe String
ns
  | Bool
otherwise = forall a. Maybe a
Nothing
  where
    ns :: String
ns = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- Int
8) String
s

-- | Split a TXT string into key and value according to RFC1464.
-- Returns 'Nothing' if parsing fails.
splitRfc1464 :: String -> Maybe (String,String)
splitRfc1464 :: String -> Maybe (String, String)
splitRfc1464 = String -> String -> Maybe (String, String)
go String
""
  where
    go :: String -> String -> Maybe (String, String)
go String
_ [] = forall a. Maybe a
Nothing
    go String
acc (Char
'`':Char
c:String
cs) = String -> String -> Maybe (String, String)
go (Char
cforall a. a -> [a] -> [a]
:String
acc) String
cs
    go String
acc (Char
'=':String
cs)   = forall {t}. t -> String -> String -> Maybe (t, String)
go2 (forall a. [a] -> [a]
reverse String
acc) String
"" String
cs
    go String
acc (Char
c:String
cs)
      | Char -> Bool
isSpace Char
c = String -> String -> Maybe (String, String)
go String
acc String
cs
      | Bool
otherwise = String -> String -> Maybe (String, String)
go (Char
cforall a. a -> [a] -> [a]
:String
acc) String
cs

    go2 :: t -> String -> String -> Maybe (t, String)
go2 t
k String
acc [] = forall a. a -> Maybe a
Just (t
k,forall a. [a] -> [a]
reverse String
acc)
    go2 t
_ String
_   [Char
'`'] = forall a. Maybe a
Nothing
    go2 t
k String
acc (Char
'`':Char
c:String
cs) = t -> String -> String -> Maybe (t, String)
go2 t
k (Char
cforall a. a -> [a] -> [a]
:String
acc) String
cs
    go2 t
k String
acc (Char
c:String
cs) = t -> String -> String -> Maybe (t, String)
go2 t
k (Char
cforall a. a -> [a] -> [a]
:String
acc) String
cs