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.
This commit is contained in:
parent
64e1d7b579
commit
9173c66e40
4 changed files with 44 additions and 16 deletions
4
Makefile
4
Makefile
|
@ -6,7 +6,7 @@ BASEFLAGS=-Wall -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility
|
||||||
# you can turn off some of these features.
|
# you can turn off some of these features.
|
||||||
#
|
#
|
||||||
# If you're using an old version of yesod, enable -DWITH_OLD_YESOD
|
# 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
|
bins=git-annex
|
||||||
mans=git-annex.1 git-annex-shell.1
|
mans=git-annex.1 git-annex-shell.1
|
||||||
|
@ -142,7 +142,7 @@ sdist: clean $(mans)
|
||||||
hackage: sdist
|
hackage: sdist
|
||||||
@cabal upload dist/*.tar.gz
|
@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
|
sha1sum sha224sum sha256sum sha384sum sha512sum
|
||||||
|
|
||||||
LINUXSTANDALONE_DEST=$(GIT_ANNEX_TMP_BUILD_DIR)/git-annex.linux
|
LINUXSTANDALONE_DEST=$(GIT_ANNEX_TMP_BUILD_DIR)/git-annex.linux
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{- SRV record lookup
|
{- SRV record lookup
|
||||||
-
|
-
|
||||||
- Uses either the ADNS Haskell library, or if it's not installed,
|
- Uses either the ADNS Haskell library, or the standalone Haskell DNS
|
||||||
- the host command.
|
- package, or the host command.
|
||||||
-
|
-
|
||||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||||
-
|
-
|
||||||
|
@ -30,6 +30,12 @@ import Data.Maybe
|
||||||
#ifdef WITH_ADNS
|
#ifdef WITH_ADNS
|
||||||
import ADNS.Resolver
|
import ADNS.Resolver
|
||||||
import Data.Either
|
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
|
#endif
|
||||||
|
|
||||||
newtype SRV = SRV String
|
newtype SRV = SRV String
|
||||||
|
@ -37,6 +43,8 @@ newtype SRV = SRV String
|
||||||
|
|
||||||
type HostPort = (HostName, PortID)
|
type HostPort = (HostName, PortID)
|
||||||
|
|
||||||
|
type PriorityWeight = (Int, Int) -- sort by priority first, then weight
|
||||||
|
|
||||||
mkSRV :: String -> String -> HostName -> SRV
|
mkSRV :: String -> String -> HostName -> SRV
|
||||||
mkSRV transport protocol host = SRV $ concat
|
mkSRV transport protocol host = SRV $ concat
|
||||||
["_", protocol, "._", transport, ".", host]
|
["_", protocol, "._", transport, ".", host]
|
||||||
|
@ -49,13 +57,27 @@ mkSRVTcp = mkSRV "tcp"
|
||||||
- On error, returns an empty list. -}
|
- On error, returns an empty list. -}
|
||||||
lookupSRV :: SRV -> IO [HostPort]
|
lookupSRV :: SRV -> IO [HostPort]
|
||||||
#ifdef WITH_ADNS
|
#ifdef WITH_ADNS
|
||||||
lookupSRV srv = initResolver [] $ \resolver -> do
|
lookupSRV (SRV srv) = initResolver [] $ \resolver -> do
|
||||||
r <- catchDefaultIO (Right []) $
|
r <- catchDefaultIO (Right []) $
|
||||||
resolveSRV resolver srv
|
resolveSRV resolver srv
|
||||||
return $ either (\_ -> []) id r
|
return $ either (\_ -> []) id r
|
||||||
#else
|
#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
|
lookupSRV = lookupSRVHost
|
||||||
#endif
|
#endif
|
||||||
|
#endif
|
||||||
|
|
||||||
lookupSRVHost :: SRV -> IO [HostPort]
|
lookupSRVHost :: SRV -> IO [HostPort]
|
||||||
lookupSRVHost (SRV srv)
|
lookupSRVHost (SRV srv)
|
||||||
|
@ -66,17 +88,22 @@ lookupSRVHost (SRV srv)
|
||||||
| otherwise = return []
|
| otherwise = return []
|
||||||
|
|
||||||
parseSrvHost :: String -> [HostPort]
|
parseSrvHost :: String -> [HostPort]
|
||||||
parseSrvHost = map snd . reverse . sortBy cost . catMaybes . map parse . lines
|
parseSrvHost = orderHosts . catMaybes . map parse . lines
|
||||||
where
|
where
|
||||||
cost = compare `on` fst
|
|
||||||
parse l = case words l of
|
parse l = case words l of
|
||||||
[_, _, _, _, priority, weight, sport, hostname] -> do
|
[_, _, _, _, spriority, sweight, sport, hostname] -> do
|
||||||
let v = readish sport :: Maybe Int
|
let v =
|
||||||
|
( readish sport :: Maybe Int
|
||||||
|
, readish spriority :: Maybe Int
|
||||||
|
, readish sweight :: Maybe Int
|
||||||
|
)
|
||||||
case v of
|
case v of
|
||||||
Nothing -> Nothing
|
(Just port, Just priority, Just weight) -> Just
|
||||||
Just port -> Just
|
|
||||||
( (priority, weight)
|
( (priority, weight)
|
||||||
, (hostname, PortNumber $ fromIntegral port)
|
, (hostname, PortNumber $ fromIntegral port)
|
||||||
)
|
)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort]
|
||||||
|
orderHosts = map snd . sortBy (compare `on` fst)
|
||||||
|
|
|
@ -43,6 +43,7 @@ quite a lot.
|
||||||
* [network-multicast](http://hackage.haskell.org/package/network-multicast)
|
* [network-multicast](http://hackage.haskell.org/package/network-multicast)
|
||||||
* [network-info](http://hackage.haskell.org/package/network-info)
|
* [network-info](http://hackage.haskell.org/package/network-info)
|
||||||
* [network-protocol-xmpp](http://hackage.haskell.org/package/network-protocol-xmpp)
|
* [network-protocol-xmpp](http://hackage.haskell.org/package/network-protocol-xmpp)
|
||||||
|
* [dns](http://hackage.haskell.org/package/dns)
|
||||||
* Shell commands
|
* Shell commands
|
||||||
* [git](http://git-scm.com/)
|
* [git](http://git-scm.com/)
|
||||||
* [uuid](http://www.ossp.org/pkg/lib/uuid/)
|
* [uuid](http://www.ossp.org/pkg/lib/uuid/)
|
||||||
|
|
|
@ -46,8 +46,8 @@ Flag Pairing
|
||||||
Flag XMPP
|
Flag XMPP
|
||||||
Description: Enable notifications using XMPP
|
Description: Enable notifications using XMPP
|
||||||
|
|
||||||
Flag Adns
|
Flag DNS
|
||||||
Description: Enable the ADNS library for DNS lookup
|
Description: Enable the haskell DNS library for DNS lookup
|
||||||
|
|
||||||
Executable git-annex
|
Executable git-annex
|
||||||
Main-Is: git-annex.hs
|
Main-Is: git-annex.hs
|
||||||
|
@ -101,9 +101,9 @@ Executable git-annex
|
||||||
Build-Depends: network-protocol-xmpp, gnutls (>= 0.1.4)
|
Build-Depends: network-protocol-xmpp, gnutls (>= 0.1.4)
|
||||||
CPP-Options: -DWITH_XMPP
|
CPP-Options: -DWITH_XMPP
|
||||||
|
|
||||||
if flag(XMPP) && flag(Assistant) && flag(Adns)
|
if flag(XMPP) && flag(Assistant) && flag(DNS)
|
||||||
Build-Depends: hsdns
|
Build-Depends: dns
|
||||||
CPP-Options: -DWITH_ADNS
|
CPP-Options: -DWITH_DNS
|
||||||
|
|
||||||
Test-Suite test
|
Test-Suite test
|
||||||
Type: exitcode-stdio-1.0
|
Type: exitcode-stdio-1.0
|
||||||
|
|
Loading…
Reference in a new issue