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.
This commit is contained in:
parent
0c01348b65
commit
3dd4b4058f
7 changed files with 174 additions and 30 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
10
templates/configurators/inprogresspairing.hamlet
Normal file
10
templates/configurators/inprogresspairing.hamlet
Normal file
|
@ -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.
|
|
@ -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.
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue