-
Notifications
You must be signed in to change notification settings - Fork 700
/
DNS.hs
196 lines (168 loc) · 7.5 KB
/
DNS.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
{-# LANGUAGE CPP #-}
module Distribution.Client.Security.DNS
( queryBootstrapMirrors
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Network.URI (URI(..), URIAuth(..), parseURI)
import Distribution.Verbosity
import Control.Monad
import Control.DeepSeq (force)
import Control.Exception (SomeException, evaluate, try)
import Distribution.Simple.Utils
import Distribution.Compat.Exception (displayException)
#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 repoUri
| Just auth <- uriAuthority repoUri = do
let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth))
mirrors' <- try $ do
txts <- queryTXT mirrorsDnsName
evaluate (force $ extractMirrors (map snd txts))
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 []
-- | Extract list of mirrors from 'queryTXT' result
extractMirrors :: [[CharStr]] -> [URI]
extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals
where
vals = [ (kn,v) | CharStr e <- concat txtChunks
, Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)]
, Just kn <- [isUrlBase 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 ++ " :")
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]
]
-- | 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 s
| ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns
| otherwise = Nothing
where
ns = take (length s - 8) s
-- | 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