never executed always true always false
1 {-# LANGUAGE CPP #-}
2
3 module Distribution.Client.Security.DNS
4 ( queryBootstrapMirrors
5 ) where
6
7 import Prelude ()
8 import Distribution.Client.Compat.Prelude
9 import Network.URI (URI(..), URIAuth(..), parseURI)
10 import Control.Exception (try)
11 import Distribution.Simple.Utils
12
13 #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
14 import Network.DNS (queryTXT, Name(..), CharStr(..))
15 import qualified Data.ByteString.Char8 as BS.Char8
16 #else
17 import Distribution.Simple.Program.Db
18 ( emptyProgramDb, addKnownProgram
19 , configureAllKnownPrograms, lookupProgram )
20 import Distribution.Simple.Program
21 ( simpleProgram
22 , programInvocation
23 , getProgramInvocationOutput )
24 #endif
25
26 -- | Try to lookup RFC1464-encoded mirror urls for a Hackage
27 -- repository url by performing a DNS TXT lookup on the
28 -- @_mirrors.@-prefixed URL hostname.
29 --
30 -- Example: for @http://hackage.haskell.org/@
31 -- perform a DNS TXT query for the hostname
32 -- @_mirrors.hackage.haskell.org@ which may look like e.g.
33 --
34 -- > _mirrors.hackage.haskell.org. 300 IN TXT
35 -- > "0.urlbase=http://hackage.fpcomplete.com/"
36 -- > "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"
37 --
38 -- NB: hackage-security doesn't require DNS lookups being trustworthy,
39 -- as the trust is established via the cryptographically signed TUF
40 -- meta-data that is retrieved from the resolved Hackage repository.
41 -- Moreover, we already have to protect against a compromised
42 -- @hackage.haskell.org@ DNS entry, so an the additional
43 -- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't
44 -- constitute a significant new attack vector anyway.
45 --
46 queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]
47
48 #if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
49 -- use @resolv@ package for performing DNS queries
50 queryBootstrapMirrors verbosity repoUri
51 | Just auth <- uriAuthority repoUri = do
52 let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth))
53
54 mirrors' <- try $ do
55 txts <- queryTXT mirrorsDnsName
56 evaluate (force $ extractMirrors (map snd txts))
57
58 mirrors <- case mirrors' of
59 Left e -> do
60 warn verbosity ("Caught exception during _mirrors lookup:"++
61 displayException (e :: SomeException))
62 return []
63 Right v -> return v
64
65 if null mirrors
66 then warn verbosity ("No mirrors found for " ++ show repoUri)
67 else do info verbosity ("located " ++ show (length mirrors) ++
68 " mirrors for " ++ show repoUri ++ " :")
69 for_ mirrors $ \url -> info verbosity ("- " ++ show url)
70
71 return mirrors
72
73 | otherwise = return []
74
75 -- | Extract list of mirrors from 'queryTXT' result
76 extractMirrors :: [[CharStr]] -> [URI]
77 extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals
78 where
79 vals = [ (kn,v) | CharStr e <- concat txtChunks
80 , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)]
81 , Just kn <- [isUrlBase k]
82 ]
83
84 ----------------------------------------------------------------------------
85 #else /* !defined(MIN_VERSION_resolv) */
86 -- use external method via @nslookup@
87 queryBootstrapMirrors verbosity repoUri
88 | Just auth <- uriAuthority repoUri = do
89 progdb <- configureAllKnownPrograms verbosity $
90 addKnownProgram nslookupProg emptyProgramDb
91
92 case lookupProgram nslookupProg progdb of
93 Nothing -> do
94 warn verbosity "'nslookup' tool missing - can't locate mirrors"
95 return []
96
97 Just nslookup -> do
98 let mirrorsDnsName = "_mirrors." ++ uriRegName auth
99
100 mirrors' <- try $ do
101 out <- getProgramInvocationOutput verbosity $
102 programInvocation nslookup ["-query=TXT", mirrorsDnsName]
103 evaluate (force $ extractMirrors mirrorsDnsName out)
104
105 mirrors <- case mirrors' of
106 Left e -> do
107 warn verbosity ("Caught exception during _mirrors lookup:"++
108 displayException (e :: SomeException))
109 return []
110 Right v -> return v
111
112 if null mirrors
113 then warn verbosity ("No mirrors found for " ++ show repoUri)
114 else do info verbosity ("located " ++ show (length mirrors) ++
115 " mirrors for " ++ show repoUri ++ " :")
116 for_ mirrors $ \url -> info verbosity ("- " ++ show url)
117
118 return mirrors
119
120 | otherwise = return []
121 where
122 nslookupProg = simpleProgram "nslookup"
123
124 -- | Extract list of mirrors from @nslookup -query=TXT@ output.
125 extractMirrors :: String -> String -> [URI]
126 extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals
127 where
128 vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0
129 , h == hostname
130 , e <- ents
131 , Just (k,v) <- [splitRfc1464 e]
132 , Just kn <- [isUrlBase k]
133 ]
134
135 -- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly
136 parseNsLookupTxt :: String -> Maybe [(String,[String])]
137 parseNsLookupTxt = go0 [] []
138 where
139 -- approximate grammar:
140 -- <entries> := { <entry> }
141 -- (<entry> starts at begin of line, but may span multiple lines)
142 -- <entry> := ^ <hostname> TAB "text =" { <qstring> }
143 -- <qstring> := string enclosed by '"'s ('\' and '"' are \-escaped)
144
145 -- scan for ^ <word> <TAB> "text ="
146 go0 [] _ [] = Nothing
147 go0 res _ [] = Just (reverse res)
148 go0 res _ ('\n':xs) = go0 res [] xs
149 go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs)
150 go0 res lw (x:xs) = go0 res (x:lw) xs
151
152 -- collect at least one <qstring>
153 go1 res lw qs ('"':xs) = case qstr "" xs of
154 Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')
155 Nothing -> Nothing -- bad quoting
156 go1 _ _ [] _ = Nothing -- missing qstring
157 go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs
158
159 qstr _ ('\n':_) = Nothing -- We don't support unquoted LFs
160 qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs
161 qstr acc ('\\':'"':cs) = qstr ('"':acc) cs
162 qstr acc ('"':cs) = Just (reverse acc, cs)
163 qstr acc (c:cs) = qstr (c:acc) cs
164 qstr _ [] = Nothing
165
166 #endif
167 ----------------------------------------------------------------------------
168
169 -- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data
170 isUrlBase :: String -> Maybe Int
171 isUrlBase s
172 | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns
173 | otherwise = Nothing
174 where
175 ns = take (length s - 8) s
176
177 -- | Split a TXT string into key and value according to RFC1464.
178 -- Returns 'Nothing' if parsing fails.
179 splitRfc1464 :: String -> Maybe (String,String)
180 splitRfc1464 = go ""
181 where
182 go _ [] = Nothing
183 go acc ('`':c:cs) = go (c:acc) cs
184 go acc ('=':cs) = go2 (reverse acc) "" cs
185 go acc (c:cs)
186 | isSpace c = go acc cs
187 | otherwise = go (c:acc) cs
188
189 go2 k acc [] = Just (k,reverse acc)
190 go2 _ _ ['`'] = Nothing
191 go2 k acc ('`':c:cs) = go2 k (c:acc) cs
192 go2 k acc (c:cs) = go2 k (c:acc) cs