summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-08 13:04:19 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-08 13:04:19 -0400
commit3dd4b4058f7796c5d08f1172fcf39c777540f80e (patch)
tree13af8c38710f1696de04b492d44c113fa8b40440
parent0c01348b65bb3d0364f90ce9785236fa05985f75 (diff)
implement pair request broadcasts
Pair requests are sent on all network interfaces, and contain the best available hostname to use to contact the host on that interface. Added a pairing in progress page. Revert "reduce some boilerplate using ghc extensions", because it caused overlapping instances for Text.
-rw-r--r--Assistant/DaemonStatus.hs4
-rw-r--r--Assistant/Pairing.hs112
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs50
-rw-r--r--Assistant/WebApp/Types.hs23
-rw-r--r--Assistant/WebApp/routes1
-rw-r--r--templates/configurators/inprogresspairing.hamlet10
-rw-r--r--templates/configurators/pairing.hamlet4
7 files changed, 174 insertions, 30 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index c6942530c..4de160ace 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -9,6 +9,7 @@ module Assistant.DaemonStatus where
import Common.Annex
import Assistant.Alert
+import Assistant.Pairing
import Utility.TempFile
import Utility.NotificationBroadcaster
import Logs.Transfer
@@ -38,6 +39,8 @@ data DaemonStatus = DaemonStatus
, lastAlertId :: AlertId
-- Ordered list of remotes to talk to.
, knownRemotes :: [Remote]
+ -- Pairing requests that are in progress.
+ , pairingInProgress :: [PairingInProgress]
-- Broadcasts notifications about all changes to the DaemonStatus
, changeNotifier :: NotificationBroadcaster
-- Broadcasts notifications when queued or current transfers change.
@@ -61,6 +64,7 @@ newDaemonStatus = DaemonStatus
<*> pure M.empty
<*> pure firstAlertId
<*> pure []
+ <*> pure []
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index 8a9d897eb..42fc29929 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -7,17 +7,24 @@
module Assistant.Pairing where
-import Assistant.Common
+import Common
import Utility.Verifiable
+import Utility.ThreadScheduler
+import Utility.Network
-import Network.Socket (HostName)
+import Network.Multicast
+import Network.Info
+import Network.Socket
+import Control.Concurrent
+import qualified Data.Map as M
-{- "I'd like to pair with somebody who knows a secret." -}
+{- "I'll pair with anybody who shares the secret that can be used to verify
+ - this request." -}
data PairReq = PairReq (Verifiable PairData)
deriving (Eq, Read, Show)
-{- "I've checked your PairReq, and like it.
- - I set up your ssh key already. Here's mine for you to set up." -}
+{- "I've verified your request, and you can verify mine to see that I know
+ - the secret. I set up your ssh key already. Here's mine for you to set up." -}
data PairAck = PairAck (Verifiable PairData)
deriving (Eq, Read, Show)
@@ -35,9 +42,102 @@ data PairMsg
data PairData = PairData
{ remoteHostName :: HostName
, remoteUserName :: UserName
- , sshPubKey :: Maybe SshPubKey
+ , sshPubKey :: SshPubKey
}
deriving (Eq, Read, Show)
type SshPubKey = String
type UserName = String
+
+{- A pairing that is in progress has a secret, and a thread that is
+ - 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 :: HostName
+multicastAddress = "224.0.0.1"
+
+type MkPairMsg = HostName -> PairMsg
+
+{- Multicasts a message repeatedly on all interfaces until its thread
+ - is killed, with a 2 second delay between each transmission.
+ -
+ - The remoteHostName is set to the best host name that can be found for
+ - each interface's IP address. When possible, that's a .local name.
+ - If not, it's whatever is found in the DNS for the address, or failing
+ - that, the 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 :: MkPairMsg -> IO ThreadId
+multicastPairMsg mkmsg = forkIO $ go =<< initMsgCache mkmsg
+ where
+ go cache = do
+ addrs <- activeNetworkAddresses
+ cache' <- updateMsgCache mkmsg cache addrs
+ mapM_ (sendinterface cache') addrs
+ threadDelaySeconds (Seconds 2)
+ go cache'
+ sendinterface cache i = void $ catchMaybeIO $ withSocketsDo $ do
+ (sock, addr) <- multicastSender multicastAddress pairingPort
+ setInterface sock (show i)
+ maybe noop (\s -> void $ sendTo sock s addr)
+ (M.lookup i cache)
+
+{- A cache of serialized messages. -}
+type MsgCache = M.Map SomeAddr String
+
+{- Ensures that the cache has messages for each address. -}
+updateMsgCache :: MkPairMsg -> MsgCache -> [SomeAddr] -> IO MsgCache
+updateMsgCache _ m [] = return m
+updateMsgCache mkmsg m (v:vs)
+ | M.member v m = updateMsgCache mkmsg m vs
+ | otherwise = do
+ let sockaddr = case v of
+ IPv4Addr (IPv4 a) -> SockAddrInet (PortNum 0) a
+ IPv6Addr (IPv6 o1 o2 o3 o4) -> SockAddrInet6 (PortNum 0) 0 (o1, o2, o3, o4) 0
+ mhostname <- catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
+ let cache' = M.insert v (show $ mkmsg $ fromMaybe (show v) mhostname) m
+ updateMsgCache mkmsg cache' vs
+
+{- An initial message cache. Look up hostname.local, and if found,
+ - put it in the cache. -}
+initMsgCache :: MkPairMsg -> IO MsgCache
+initMsgCache mkmsg = go =<< getHostname
+ where
+ go Nothing = return M.empty
+ go (Just n) = do
+ let localname = n ++ ".local"
+ addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
+ case headMaybe addrs of
+ Nothing -> return M.empty
+ Just addr -> case addrAddress addr of
+ SockAddrInet _ a ->
+ use localname $
+ IPv4Addr $ IPv4 a
+ SockAddrInet6 _ _ (o1, o2, o3, o4) _ ->
+ use localname $
+ IPv6Addr $ IPv6 o1 o2 o3 o4
+ _ -> return M.empty
+ use hostname addr = return $ M.fromList [(addr, show $ mkmsg hostname)]
+
+data SomeAddr = IPv4Addr IPv4 | IPv6Addr IPv6
+ deriving (Ord, Eq)
+
+instance Show SomeAddr where
+ show (IPv4Addr x) = show x
+ show (IPv6Addr x) = show x
+
+activeNetworkAddresses :: IO [SomeAddr]
+activeNetworkAddresses = filter (not . all (`elem` "0.:") . show)
+ . concat . map (\ni -> [IPv4Addr $ ipv4 ni, IPv6Addr $ ipv6 ni])
+ <$> getNetworkInterfaces
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 82f413a00..350319864 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -3,8 +3,8 @@
- Pairing works like this:
-
- * The user opens StartPairR, which prompts them for a secret.
- - * The user submits it. A PairReq is broadcast out. The secret is
- - stashed away in a list of known pairing secrets.
+ - * The user submits it. The pairing secret is stored for later.
+ - A PairReq is broadcast out.
- * On another device, it's received, and that causes its webapp to
- display an Alert.
- * The user there clicks the button, which opens FinishPairR,
@@ -15,8 +15,8 @@
- * The PairAck is received back at the device that started the process.
- It's verified using the stored secret. The ssh key from the PairAck
- is added. An Alert is displayed noting that the pairing has been set
- - up. Note that multiple other devices could also send PairAcks, and
- - as long as they're valid, all those devices are paired with.
+ - up. The pairing secret is removed to prevent anyone cracking the
+ - crypto.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
@@ -29,6 +29,7 @@ module Assistant.WebApp.Configurators.Pairing where
import Assistant.Common
import Assistant.Pairing
+import Assistant.DaemonStatus
import Utility.Verifiable
import Assistant.WebApp
import Assistant.WebApp.Types
@@ -44,35 +45,48 @@ import Data.Char
import System.Posix.User
getStartPairR :: Handler RepHtml
-getStartPairR = bootstrap (Just Config) $ do
+getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
+ username <- liftIO $ getUserName
+ let sshkey = "" -- TODO generate/read ssh key
+ let mkmsg hostname = PairReqM $ PairReq $
+ mkVerifiable (PairData hostname username sshkey) secret
+ pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
+ dstatus <- daemonStatus <$> lift getYesod
+ liftIO $ modifyDaemonStatus_ dstatus $
+ \s -> s { pairingInProgress = pip : pairingInProgress s }
+ lift $ redirect $ InprogressPairR rawsecret
+
+getInprogressPairR :: Text -> Handler RepHtml
+getInprogressPairR secret = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Pairing"
- promptSecret Nothing $ error "TODO"
+ $(widgetFile "configurators/inprogresspairing")
getFinishPairR :: PairReq -> Handler RepHtml
-getFinishPairR req = bootstrap (Just Config) $ do
- sideBarDisplay
- setTitle "Pairing"
- promptSecret (Just req) $ error "TODO"
+getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
+ error "TODO"
data InputSecret = InputSecret { secretText :: Maybe Text }
-promptSecret :: Maybe PairReq -> Widget -> Widget
-promptSecret req cont = do
+promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml
+promptSecret req cont = bootstrap (Just Config) $ do
+ sideBarDisplay
+ setTitle "Pairing"
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $
InputSecret <$> aopt textField "Secret phrase" Nothing
case result of
FormSuccess v -> do
- let secret = toSecret $ fromMaybe "" $ secretText v
+ let rawsecret = fromMaybe "" $ secretText v
+ let secret = toSecret rawsecret
case req of
Nothing -> case secretProblem secret of
- Nothing -> cont
+ Nothing -> cont rawsecret secret
Just problem ->
showform form enctype $ Just problem
Just r ->
if verified (fromPairReq r) secret
- then cont
+ then cont rawsecret secret
else showform form enctype $ Just
"That's not the right secret phrase."
_ -> showform form enctype Nothing
@@ -84,8 +98,7 @@ promptSecret req cont = do
let (username, hostname) = maybe ("", "")
(\v -> (T.pack $ remoteUserName v, T.pack $ remoteHostName v))
(verifiableVal . fromPairReq <$> req)
- u <- liftIO $ T.pack . userName
- <$> (getUserEntryForID =<< getEffectiveUserID)
+ u <- T.pack <$> liftIO getUserName
let sameusername = username == u
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/pairing")
@@ -110,3 +123,6 @@ sampleQuote = T.unwords
, "it was the age of wisdom,"
, "it was the age of foolishness."
]
+
+getUserName :: IO String
+getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index b88e78d67..dd3bd4383 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -5,9 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.WebApp.Types where
@@ -79,7 +77,22 @@ data SshData = SshData
}
deriving (Read, Show, Eq)
-{- Allow any serializable data type to be used as a PathPiece -}
-instance (Show a, Read a) => PathPiece a where
+instance PathPiece SshData where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
+instance PathPiece NotificationId where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
+instance PathPiece AlertId where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
+instance PathPiece Transfer where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
+instance PathPiece PairReq where
toPathPiece = pack . show
fromPathPiece = readish . unpack
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 5bab0cc63..181b08f28 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -12,6 +12,7 @@
/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
/config/repository/add/rsync.net AddRsyncNetR GET
/config/repository/pair/start StartPairR GET
+/config/repository/pair/inprogress/#Text InprogressPairR GET
/config/repository/pair/finish/#PairReq FinishPairR GET
/config/repository/first FirstRepositoryR GET
diff --git a/templates/configurators/inprogresspairing.hamlet b/templates/configurators/inprogresspairing.hamlet
new file mode 100644
index 000000000..7b655b5a9
--- /dev/null
+++ b/templates/configurators/inprogresspairing.hamlet
@@ -0,0 +1,10 @@
+<div .span9 .hero-unit>
+ <h2>
+ Pairing in progress ..
+ <p>
+ Now you should either go tell the owner of the computer you want to pair #
+ with the secret phrase you selected ("#{secret}"), or go enter it into #
+ the computer you want to pair with.
+ <p>
+ You do not need to leave this page open; pairing will finish automatically #
+ as soon as the secret phrase is entered into the other computer.
diff --git a/templates/configurators/pairing.hamlet b/templates/configurators/pairing.hamlet
index 4aa1cdbb0..eb16e5b6d 100644
--- a/templates/configurators/pairing.hamlet
+++ b/templates/configurators/pairing.hamlet
@@ -5,7 +5,7 @@
$if start
Pair with a computer on your local network (or VPN), and the #
two git annex repositories will be combined into one, with changes #
- kept in sync between all paired devices.
+ kept in sync between them.
$else
Pairing with #{username}@#{hostname} will combine the two git annex #
repositories into one, with changes kept in sync between them.
@@ -46,5 +46,5 @@
A quotation is one good choice, something like: #
"#{sampleQuote}"
$else
- Only letters and numbers matter; punctuation and white space is #
+ Only letters and numbers matter; punctuation and spaces are #
ignored.