-
Notifications
You must be signed in to change notification settings - Fork 697
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #3947 from hvr/pr/mirrors-bootstrap
Implement DNS-based mirror bootstrap protocol
- Loading branch information
Showing
3 changed files
with
170 additions
and
15 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters