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