support using haskell-dns for SRV lookups

This library should be easier to install than ADNS, so I've made it
be used by default.

4 files changed, 44 insertions, 16 deletions

diff --git a/Makefile b/Makefile
index a9426f7d6..701b7ff87 100644
--- a/Makefile
+++ b/Makefile
@@ -6,7 +6,7 @@ BASEFLAGS=-Wall -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility
 # you can turn off some of these features.
 #
 # If you're using an old version of yesod, enable -DWITH_OLD_YESOD
-FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP
+FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP -DWITH_DNS
 
 bins=git-annex
 mans=git-annex.1 git-annex-shell.1
@@ -142,7 +142,7 @@ sdist: clean $(mans)
 hackage: sdist
 	@cabal upload dist/*.tar.gz
 
-THIRDPARTY_BINS=git curl lsof xargs rsync uuid wget gpg host \
+THIRDPARTY_BINS=git curl lsof xargs rsync uuid wget gpg \
 	sha1sum sha224sum sha256sum sha384sum sha512sum
 
 LINUXSTANDALONE_DEST=$(GIT_ANNEX_TMP_BUILD_DIR)/git-annex.linux
diff --git a/Utility/SRV.hs b/Utility/SRV.hs
index 4f2db680b..d9c70321b 100644
--- a/Utility/SRV.hs
+++ b/Utility/SRV.hs
@@ -1,7 +1,7 @@
 {- SRV record lookup
  -
- - Uses either the ADNS Haskell library, or if it's not installed,
- - the host command.
+ - Uses either the ADNS Haskell library, or the standalone Haskell DNS
+ - package, or the host command.
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
@@ -30,6 +30,12 @@ import Data.Maybe
 #ifdef WITH_ADNS
 import ADNS.Resolver
 import Data.Either
+#else
+#ifdef WITH_DNS
+import qualified Network.DNS.Lookup as DNS
+import Network.DNS.Resolver
+import qualified Data.ByteString.UTF8 as B8
+#endif
 #endif
 
 newtype SRV = SRV String
@@ -37,6 +43,8 @@ newtype SRV = SRV String
 
 type HostPort = (HostName, PortID)
 
+type PriorityWeight = (Int, Int) -- sort by priority first, then weight
+
 mkSRV :: String -> String -> HostName -> SRV
 mkSRV transport protocol host = SRV $ concat
 	["_", protocol, "._", transport, ".", host]
@@ -49,13 +57,27 @@ mkSRVTcp = mkSRV "tcp"
  - On error, returns an empty list. -}
 lookupSRV :: SRV -> IO [HostPort]
 #ifdef WITH_ADNS
-lookupSRV srv = initResolver [] $ \resolver -> do
+lookupSRV (SRV srv) = initResolver [] $ \resolver -> do
 	r <- catchDefaultIO (Right []) $
 		resolveSRV resolver srv
 	return $ either (\_ -> []) id r
 #else
+#ifdef WITH_DNS
+lookupSRV (SRV srv) = do
+	seed <- makeResolvSeed defaultResolvConf
+	print srv
+	r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv
+	print r
+	return $ maybe [] (orderHosts . map tohosts) r
+	where
+		tohosts (priority, weight, port, hostname) =
+			( (priority, weight)
+			, (B8.toString hostname, PortNumber $ fromIntegral port)
+			)
+#else
 lookupSRV = lookupSRVHost
 #endif
+#endif
 
 lookupSRVHost :: SRV -> IO [HostPort]
 lookupSRVHost (SRV srv)
@@ -66,17 +88,22 @@ lookupSRVHost (SRV srv)
 	| otherwise = return []
 
 parseSrvHost :: String -> [HostPort]
-parseSrvHost = map snd . reverse . sortBy cost . catMaybes . map parse . lines
+parseSrvHost = orderHosts . catMaybes . map parse . lines
 	where
-		cost = compare `on` fst
 		parse l = case words l of
-			[_, _, _, _, priority, weight, sport, hostname] -> do
-				let v = readish sport :: Maybe Int
+			[_, _, _, _, spriority, sweight, sport, hostname] -> do
+				let v = 
+					( readish sport :: Maybe Int
+					, readish spriority :: Maybe Int
+					, readish sweight :: Maybe Int
+					)
 				case v of
-					Nothing -> Nothing
-					Just port -> Just
+					(Just port, Just priority, Just weight) -> Just
 						( (priority, weight)
 						, (hostname, PortNumber $ fromIntegral port)
 						)
+					_ -> Nothing
 			_ -> Nothing
 
+orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort]
+orderHosts = map snd . sortBy (compare `on` fst)
diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn
index f79ae7dc7..57b92237e 100644
--- a/doc/install/fromscratch.mdwn
+++ b/doc/install/fromscratch.mdwn
@@ -43,6 +43,7 @@ quite a lot.
   * [network-multicast](http://hackage.haskell.org/package/network-multicast)
   * [network-info](http://hackage.haskell.org/package/network-info)
   * [network-protocol-xmpp](http://hackage.haskell.org/package/network-protocol-xmpp)
+  * [dns](http://hackage.haskell.org/package/dns)
 * Shell commands
   * [git](http://git-scm.com/)
   * [uuid](http://www.ossp.org/pkg/lib/uuid/)
diff --git a/git-annex.cabal b/git-annex.cabal
index 4e910183c..7d83239a0 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -46,8 +46,8 @@ Flag Pairing
 Flag XMPP
   Description: Enable notifications using XMPP
 
-Flag Adns
-  Description: Enable the ADNS library for DNS lookup
+Flag DNS
+  Description: Enable the haskell DNS library for DNS lookup
 
 Executable git-annex
   Main-Is: git-annex.hs
@@ -101,9 +101,9 @@ Executable git-annex
     Build-Depends: network-protocol-xmpp, gnutls (>= 0.1.4)
     CPP-Options: -DWITH_XMPP
 
-  if flag(XMPP) && flag(Assistant) && flag(Adns)
-    Build-Depends: hsdns
-    CPP-Options: -DWITH_ADNS
+  if flag(XMPP) && flag(Assistant) && flag(DNS)
+    Build-Depends: dns
+    CPP-Options: -DWITH_DNS
 
 Test-Suite test
   Type: exitcode-stdio-1.0