c784ef4586
Removed old extensible-exceptions, only needed for very old ghc. Made webdav use Utility.Exception, to work after some changes in DAV's exception handling. Removed Annex.Exception. Mostly this was trivial, but note that tryAnnex is replaced with tryNonAsync and catchAnnex replaced with catchNonAsync. In theory that could be a behavior change, since the former caught all exceptions, and the latter don't catch async exceptions. However, in practice, nothing in the Annex monad uses async exceptions. Grepping for throwTo and killThread only find stuff in the assistant, which does not seem related. Command.Add.undo is changed to accept a SomeException, and things that use it for rollback now catch non-async exceptions, rather than only IOExceptions.
129 lines
4.4 KiB
Haskell
129 lines
4.4 KiB
Haskell
{- git-annex assistant pairing network code
|
|
-
|
|
- All network traffic is sent over multicast UDP. For reliability,
|
|
- each message is repeated until acknowledged. This is done using a
|
|
- thread, that gets stopped before the next message is sent.
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Pairing.Network where
|
|
|
|
import Assistant.Common
|
|
import Assistant.Pairing
|
|
import Assistant.DaemonStatus
|
|
import Utility.ThreadScheduler
|
|
import Utility.Verifiable
|
|
|
|
import Network.Multicast
|
|
import Network.Info
|
|
import Network.Socket
|
|
import qualified Data.Map as M
|
|
import Control.Concurrent
|
|
|
|
{- 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
|
|
|
|
{- Goal: Reach all hosts on the same network segment.
|
|
- Method: Use same address that avahi uses. Other broadcast addresses seem
|
|
- to not be let through some routers. -}
|
|
multicastAddress :: SomeAddr -> HostName
|
|
multicastAddress (IPv4Addr _) = "224.0.0.251"
|
|
multicastAddress (IPv6Addr _) = "ff02::fb"
|
|
|
|
{- Multicasts a message repeatedly on all interfaces, with a 2 second
|
|
- delay between each transmission. The message is repeated forever
|
|
- unless a number of repeats is specified.
|
|
-
|
|
- 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 :: Maybe Int -> Secret -> PairData -> PairStage -> IO ()
|
|
multicastPairMsg repeats secret pairdata stage = go M.empty repeats
|
|
where
|
|
go _ (Just 0) = noop
|
|
go cache n = do
|
|
addrs <- activeNetworkAddresses
|
|
let cache' = updatecache cache addrs
|
|
mapM_ (sendinterface cache') addrs
|
|
threadDelaySeconds (Seconds 2)
|
|
go cache' $ pred <$> n
|
|
{- The multicast library currently chokes on ipv6 addresses. -}
|
|
sendinterface _ (IPv6Addr _) = noop
|
|
sendinterface cache i = void $ tryIO $
|
|
withSocketsDo $ bracket setup cleanup use
|
|
where
|
|
setup = multicastSender (multicastAddress i) pairingPort
|
|
cleanup (sock, _) = sClose sock -- FIXME does not work
|
|
use (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
|
|
mkmsg addr = PairMsg $
|
|
mkVerifiable (stage, pairdata, addr) secret
|
|
|
|
startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant ()
|
|
startSending pip stage sender = do
|
|
a <- asIO start
|
|
void $ liftIO $ forkIO a
|
|
where
|
|
start = do
|
|
tid <- liftIO myThreadId
|
|
let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
|
|
oldpip <- modifyDaemonStatus $
|
|
\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
|
|
maybe noop stopold oldpip
|
|
liftIO $ sender stage
|
|
stopold = maybe noop (liftIO . killThread) . inProgressThreadId
|
|
|
|
stopSending :: PairingInProgress -> Assistant ()
|
|
stopSending pip = do
|
|
maybe noop (liftIO . killThread) $ inProgressThreadId pip
|
|
modifyDaemonStatus_ $ \s -> s { pairingInProgress = 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)
|
|
. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
|
|
<$> getNetworkInterfaces
|
|
|
|
{- A human-visible description of the repository being paired with.
|
|
- Note that the repository's description is not shown to the user, because
|
|
- it could be something like "my repo", which is confusing when pairing
|
|
- with someone else's repo. However, this has the same format as the
|
|
- default decription of a repo. -}
|
|
pairRepo :: PairMsg -> String
|
|
pairRepo msg = concat
|
|
[ remoteUserName d
|
|
, "@"
|
|
, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)
|
|
, ":"
|
|
, remoteDirectory d
|
|
]
|
|
where
|
|
d = pairMsgData msg
|