summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-18 12:54:22 +0000