{-# 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
queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]
#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
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." String -> String -> String
forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriRegName URIAuth
auth))
Either SomeException [URI]
mirrors' <- IO [URI] -> IO (Either SomeException [URI])
forall e a. Exception e => IO a -> IO (Either e a)
try (IO [URI] -> IO (Either SomeException [URI]))
-> IO [URI] -> IO (Either SomeException [URI])
forall a b. (a -> b) -> a -> b
$ do
[(TTL, [CharStr])]
txts <- Name -> IO [(TTL, [CharStr])]
queryTXT Name
mirrorsDnsName
[URI] -> IO [URI]
forall a. a -> IO a
evaluate ([URI] -> [URI]
forall a. NFData a => a -> a
force ([URI] -> [URI]) -> [URI] -> [URI]
forall a b. (a -> b) -> a -> b
$ [[CharStr]] -> [URI]
extractMirrors (((TTL, [CharStr]) -> [CharStr])
-> [(TTL, [CharStr])] -> [[CharStr]]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, [CharStr]) -> [CharStr]
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:"String -> String -> String
forall a. [a] -> [a] -> [a]
++
SomeException -> String
forall e. Exception e => e -> String
displayException (SomeException
e :: SomeException))
[URI] -> IO [URI]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Right [URI]
v -> [URI] -> IO [URI]
forall (m :: * -> *) a. Monad m => a -> m a
return [URI]
v
if [URI] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [URI]
mirrors
then Verbosity -> String -> IO ()
warn Verbosity
verbosity (String
"No mirrors found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
repoUri)
else do Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"located " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([URI] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [URI]
mirrors) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" mirrors for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
repoUri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :")
[URI] -> (URI -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [URI]
mirrors ((URI -> IO ()) -> IO ()) -> (URI -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \URI
url -> Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
url)
[URI] -> IO [URI]
forall (m :: * -> *) a. Monad m => a -> m a
return [URI]
mirrors
| Bool
otherwise = [URI] -> IO [URI]
forall (m :: * -> *) a. Monad m => a -> m a
return []
extractMirrors :: [[CharStr]] -> [URI]
[[CharStr]]
txtChunks = ((Int, String) -> Maybe URI) -> [(Int, String)] -> [URI]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe URI
parseURI (String -> Maybe URI)
-> ((Int, String) -> String) -> (Int, String) -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, String) -> String
forall a b. (a, b) -> b
snd) ([(Int, String)] -> [URI])
-> ([(Int, String)] -> [(Int, String)]) -> [(Int, String)] -> [URI]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, String)] -> [(Int, String)]
forall a. Ord a => [a] -> [a]
sort ([(Int, String)] -> [URI]) -> [(Int, String)] -> [URI]
forall a b. (a -> b) -> a -> b
$ [(Int, String)]
vals
where
vals :: [(Int, String)]
vals = [ (Int
kn,String
v) | CharStr ByteString
e <- [[CharStr]] -> [CharStr]
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) */
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"
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]
]
parseNsLookupTxt :: String -> Maybe [(String,[String])]
parseNsLookupTxt = go0 [] []
where
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
go1 res lw qs ('"':xs) = case qstr "" xs of
Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')
Nothing -> Nothing
go1 _ _ [] _ = Nothing
go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs
qstr _ ('\n':_) = Nothing
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
isUrlBase :: String -> Maybe Int
isUrlBase :: String -> Maybe Int
isUrlBase String
s
| String
".urlbase" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
s, Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ns), (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
ns = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
ns
| Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
where
ns :: String
ns = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8) String
s
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
_ [] = Maybe (String, String)
forall a. Maybe a
Nothing
go String
acc (Char
'`':Char
c:String
cs) = String -> String -> Maybe (String, String)
go (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs
go String
acc (Char
'=':String
cs) = String -> String -> String -> Maybe (String, String)
forall t. t -> String -> String -> Maybe (t, String)
go2 (String -> String
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
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs
go2 :: t -> String -> String -> Maybe (t, String)
go2 t
k String
acc [] = (t, String) -> Maybe (t, String)
forall a. a -> Maybe a
Just (t
k,String -> String
forall a. [a] -> [a]
reverse String
acc)
go2 t
_ String
_ [Char
'`'] = Maybe (t, String)
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
cChar -> String -> String
forall 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
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs