fix build without pairing support
This commit is contained in:
Joey Hess
parent
0f0c7f8d70
commit
61ee1e1660
4 changed files with 113 additions and 96 deletions
|
|
@ -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
|
||||
|
|
|
|||
103
Assistant/Pairing/Network.hs
Normal file
103
Assistant/Pairing/Network.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue