forked from haskell/cabal
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Implement DNS-based mirror bootstrap protocol
This way `cabal` can bootstrap secure repos even if the primary Hackage instance is currently unreachable, as long as there's at least one reachable and working secure mirror available. NB: This new code-path is only used for the initial bootstrap. Once the repository cache has been bootstrapped, its `mirrors.json` meta-data is used instead. See also haskell/hackage-security#171
- Loading branch information
Showing
3 changed files
with
148 additions
and
7 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,134 @@ | ||
| module Distribution.Client.Security.DNS | ||
| ( queryBootstrapMirrors | ||
| ) where | ||
|
|
||
| import Prelude () | ||
| import Distribution.Client.Compat.Prelude | ||
|
|
||
| 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 Control.Monad | ||
| import Control.DeepSeq (force) | ||
| import Control.Exception | ||
|
|
||
| -- | 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/" | ||
| -- | ||
| queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] | ||
| queryBootstrapMirrors verbosity repoUri | ||
| | uriScheme repoUri `elem` ["http:","https:"] | ||
| , 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 -> (e::SomeException) `seq` 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