diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Pairing.hs | 94 | ||||
| -rw-r--r-- | Assistant/Pairing/Network.hs | 103 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 1 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 11 |
4 files changed, 113 insertions, 96 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index 2ad339969..eced43793 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -1,4 +1,4 @@ -{- git-annex assistant repo pairing +{- git-annex assistant repo pairing, core data types - - Copyright 2012 Joey Hess <joey@kitenet.net> - @@ -7,16 +7,10 @@ module Assistant.Pairing where -import Common import Utility.Verifiable -import Utility.ThreadScheduler -import Network.Multicast -import Network.Info -import Network.Socket import Control.Concurrent -import Control.Exception (bracket) -import qualified Data.Map as M +import Network.Socket {- "I'll pair with anybody who shares the secret that can be used to verify - this request." -} @@ -55,89 +49,5 @@ type UserName = String - broadcasting pairing requests. -} data PairingInProgress = PairingInProgress Secret ThreadId -{- This is an arbitrary port in the dynamic port range, that could - - conceivably be used for some other broadcast messages. - - If so, hope they ignore the garbage from us; we'll certianly - - ignore garbage from them. Wild wild west. -} -pairingPort :: PortNumber -pairingPort = 55556 - -{- This is the All Hosts multicast group, which should reach all hosts - - on the same network segment. -} -multicastAddress :: SomeAddr -> HostName -multicastAddress (IPv4Addr _) = "224.0.0.1" -multicastAddress (IPv6Addr _) = "ff02::1" - -{- Multicasts a message repeatedly on all interfaces until its thread - - is killed, with a 2 second delay between each transmission. - - - - The remoteHostAddress is set to the interface's IP address. - - - - Note that new sockets are opened each time. This is hardly efficient, - - but it allows new network interfaces to be used as they come up. - - On the other hand, the expensive DNS lookups are cached. - -} -multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ThreadId -multicastPairMsg mkmsg = forkIO $ go M.empty - where - go cache = do - addrs <- activeNetworkAddresses - let cache' = updatecache cache addrs - mapM_ (sendinterface cache') addrs - threadDelaySeconds (Seconds 2) - go cache' - sendinterface cache i = void $ catchMaybeIO $ - withSocketsDo $ bracket - (multicastSender (multicastAddress i) pairingPort) - (sClose . fst) - (\(sock, addr) -> do - setInterface sock (showAddr i) - maybe noop (\s -> void $ sendTo sock s addr) - (M.lookup i cache) - ) - updatecache cache [] = cache - updatecache cache (i:is) - | M.member i cache = updatecache cache is - | otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is - -{- Finds the best hostname to use for the host that sent the PairData. - - - - If remoteHostName is set, tries to use a .local address based on it. - - That's the most robust, if this system supports .local. - - Otherwise, looks up the hostname in the DNS for the remoteAddress, - - if any. May fall back to remoteAddress if there's no DNS. Ugh. -} -bestHostName :: PairData -> IO HostName -bestHostName d = case remoteHostName d of - Just h -> do - let localname = h ++ ".local" - addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) [] - maybe fallback (const $ return localname) (headMaybe addrs) - Nothing -> fallback - where - fallback = do - let sockaddr = case remoteAddress d of - IPv4Addr a -> SockAddrInet (PortNum 0) a - IPv6Addr a -> SockAddrInet6 (PortNum 0) 0 a 0 - fromMaybe (show $ remoteAddress d) - <$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing - data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6 deriving (Ord, Eq, Read, Show) - -class ToSomeAddr a where - toSomeAddr :: a -> SomeAddr - -instance ToSomeAddr IPv4 where - toSomeAddr (IPv4 a) = IPv4Addr a - -instance ToSomeAddr IPv6 where - toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4) - -showAddr :: SomeAddr -> HostName -showAddr (IPv4Addr a) = show $ IPv4 a -showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4 - -activeNetworkAddresses :: IO [SomeAddr] -activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr) - . concat . map (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni]) - <$> getNetworkInterfaces diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs new file mode 100644 index 000000000..ec7054f9e --- /dev/null +++ b/Assistant/Pairing/Network.hs @@ -0,0 +1,103 @@ +{- git-annex assistant pairing network code + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Pairing.Network where + +import Common +import Assistant.Pairing +import Utility.ThreadScheduler + +import Network.Multicast +import Network.Info +import Network.Socket +import Control.Concurrent +import Control.Exception (bracket) +import qualified Data.Map as M + +{- This is an arbitrary port in the dynamic port range, that could + - conceivably be used for some other broadcast messages. + - If so, hope they ignore the garbage from us; we'll certianly + - ignore garbage from them. Wild wild west. -} +pairingPort :: PortNumber +pairingPort = 55556 + +{- This is the All Hosts multicast group, which should reach all hosts + - on the same network segment. -} +multicastAddress :: SomeAddr -> HostName +multicastAddress (IPv4Addr _) = "224.0.0.1" +multicastAddress (IPv6Addr _) = "ff02::1" + +{- Multicasts a message repeatedly on all interfaces until its thread + - is killed, with a 2 second delay between each transmission. + - + - The remoteHostAddress is set to the interface's IP address. + - + - Note that new sockets are opened each time. This is hardly efficient, + - but it allows new network interfaces to be used as they come up. + - On the other hand, the expensive DNS lookups are cached. + -} +multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ThreadId +multicastPairMsg mkmsg = forkIO $ go M.empty + where + go cache = do + addrs <- activeNetworkAddresses + let cache' = updatecache cache addrs + mapM_ (sendinterface cache') addrs + threadDelaySeconds (Seconds 2) + go cache' + sendinterface cache i = void $ catchMaybeIO $ + withSocketsDo $ bracket + (multicastSender (multicastAddress i) pairingPort) + (sClose . fst) + (\(sock, addr) -> do + setInterface sock (showAddr i) + maybe noop (\s -> void $ sendTo sock s addr) + (M.lookup i cache) + ) + updatecache cache [] = cache + updatecache cache (i:is) + | M.member i cache = updatecache cache is + | otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is + +{- Finds the best hostname to use for the host that sent the PairData. + - + - If remoteHostName is set, tries to use a .local address based on it. + - That's the most robust, if this system supports .local. + - Otherwise, looks up the hostname in the DNS for the remoteAddress, + - if any. May fall back to remoteAddress if there's no DNS. Ugh. -} +bestHostName :: PairData -> IO HostName +bestHostName d = case remoteHostName d of + Just h -> do + let localname = h ++ ".local" + addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) [] + maybe fallback (const $ return localname) (headMaybe addrs) + Nothing -> fallback + where + fallback = do + let sockaddr = case remoteAddress d of + IPv4Addr a -> SockAddrInet (PortNum 0) a + IPv6Addr a -> SockAddrInet6 (PortNum 0) 0 a 0 + fromMaybe (show $ remoteAddress d) + <$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing + +class ToSomeAddr a where + toSomeAddr :: a -> SomeAddr + +instance ToSomeAddr IPv4 where + toSomeAddr (IPv4 a) = IPv4Addr a + +instance ToSomeAddr IPv6 where + toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4) + +showAddr :: SomeAddr -> HostName +showAddr (IPv4Addr a) = show $ IPv4 a +showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4 + +activeNetworkAddresses :: IO [SomeAddr] +activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr) + . concat . map (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni]) + <$> getNetworkInterfaces diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index f76f0ed4e..bb9ab6d0f 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -9,6 +9,7 @@ module Assistant.Threads.PairListener where import Assistant.Common import Assistant.Pairing +import Assistant.Pairing.Network import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.Alert diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index d79752426..cc7d1cf77 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -28,25 +28,28 @@ module Assistant.WebApp.Configurators.Pairing where -import Assistant.Common -#ifdef WITH_PAIRING import Assistant.Pairing -#endif +#ifdef WITH_PAIRING +import Assistant.Pairing.Network +import Assistant.Common import Assistant.DaemonStatus import Utility.Verifiable +import Utility.Network +#endif import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.SideBar import Utility.Yesod -import Utility.Network import Yesod import Data.Text (Text) +#ifdef WITH_PAIRING import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as B import Data.Char import System.Posix.User +#endif getStartPairR :: Handler RepHtml #ifdef WITH_PAIRING |