diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/DaemonStatus.hs | 4 | ||||
| -rw-r--r-- | Assistant/Pairing.hs | 112 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 50 | ||||
| -rw-r--r-- | Assistant/WebApp/Types.hs | 23 | ||||
| -rw-r--r-- | Assistant/WebApp/routes | 1 |
5 files changed, 162 insertions, 28 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 |