From c20d6f4189e1e0c3a1e8339f772df587fac38748 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Sep 2012 17:53:51 -0400 Subject: responding to pair requests *almost* works --- Assistant/WebApp/Configurators/Pairing.hs | 145 +++++++++++++++++++----------- Assistant/WebApp/Configurators/Ssh.hs | 21 +++-- 2 files changed, 104 insertions(+), 62 deletions(-) (limited to 'Assistant/WebApp/Configurators') diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index da54e6a88..96c053b86 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -11,12 +11,14 @@ - which prompts them for the same secret. - * The secret is used to verify the PairReq. If it checks out, - a PairAck is sent, and the other device adds the ssh key from the - - PairReq. An Alert is displayed noting that the pairing has been set up. + - PairReq to its authorized_keys, and sets up the remote. - * 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. The pairing secret is removed to prevent anyone cracking the - - crypto. + - crypto. Syncing starts. A PairDone is sent. + - * The PairDone is received, and an alert shown indicating pairing is + - done. - - Copyright 2012 Joey Hess - @@ -34,9 +36,10 @@ import Assistant.WebApp.Types import Assistant.WebApp.SideBar import Utility.Yesod #ifdef WITH_PAIRING +import Assistant.Common import Assistant.Pairing.Network import Assistant.Ssh -import Assistant.Common +import qualified Assistant.WebApp.Configurators.Ssh as Ssh import Assistant.Alert import Assistant.DaemonStatus import Utility.Verifiable @@ -57,74 +60,110 @@ import Control.Concurrent getStartPairR :: Handler RepHtml #ifdef WITH_PAIRING -getStartPairR = promptSecret Nothing $ \rawsecret secret -> do +getStartPairR = do + keypair <- liftIO genSshKeyPair + promptSecret Nothing $ startPairing PairReq keypair noop +#else +getStartPairR = noPairing +#endif + +getFinishPairR :: PairMsg -> Handler RepHtml +#ifdef WITH_PAIRING +getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do + keypair <- setup + startPairing PairAck keypair cleanup "" secret + where + pubkey = remoteSshPubKey $ pairMsgData msg + setup = do + unlessM (liftIO $ makeAuthorizedKeys False pubkey) $ + error "failed setting up ssh authorized keys" + keypair <- liftIO genSshKeyPair + let d = pairMsgData msg + besthostname <- liftIO $ bestHostName d + let sshdata = SshData + { sshHostName = T.pack besthostname + , sshUserName = Just (T.pack $ remoteUserName d) + , sshDirectory = T.pack (remoteDirectory d) + , sshRepoName = genSshRepoName besthostname (remoteDirectory d) + , needsPubKey = True + , rsyncOnly = False + } + sshdata' <- liftIO $ setupSshKeyPair keypair sshdata + void $ lift $ Ssh.makeSshWithKeyPair False sshdata' (Just keypair) + return keypair + cleanup = error "TODO clean up authorized keys and generated ssh key and remove git remote" +#else +getFinishPairR _ = noPairing +#endif + +getInprogressPairR :: Text -> Handler RepHtml +#ifdef WITH_PAIRING +getInprogressPairR secret = pairPage $ do + $(widgetFile "configurators/pairing/inprogress") +#else +getInprogressPairR _ = noPairing +#endif + +#ifdef WITH_PAIRING + +{- Starts pairing, at either the PairReq (initiating host) or + - PairAck (responding host) stage. + - + - Displays an alert, and starts a thread sending the pairing message, + - which will continue running until the other host responds, or until + - canceled by the user. If canceled by the user, runs the oncancel action. + - + - Redirects to the pairing in progress page. + -} +startPairing :: PairStage -> SshKeyPair -> IO () -> Text -> Secret -> Widget +startPairing stage keypair oncancel displaysecret secret = do dstatus <- daemonStatus <$> lift getYesod urlrender <- lift getUrlRender let homeurl = urlrender HomeR - hostname <- liftIO getHostname - username <- liftIO getUserName - reldir <- fromJust . relDir <$> lift getYesod - keypair <- liftIO genSshKeyPair - let pubkey = sshPubKey keypair ++ "foo" - let mkmsg addr = PairMsg $ mkVerifiable - (PairReq, PairData hostname addr username reldir pubkey) secret + sender <- mksender liftIO $ do pip <- PairingInProgress secret - <$> sendrequests mkmsg dstatus homeurl + <$> sendrequests sender dstatus homeurl <*> pure keypair oldpip <- modifyDaemonStatus dstatus $ \s -> (s { pairingInProgress = Just pip }, pairingInProgress s) maybe noop stopold oldpip - lift $ redirect $ InprogressPairR rawsecret + lift $ redirect $ InprogressPairR displaysecret where + mksender = do + hostname <- liftIO getHostname + username <- liftIO getUserName + reldir <- fromJust . relDir <$> lift getYesod + return $ multicastPairMsg $ \addr -> PairMsg $ mkVerifiable + (stage, PairData hostname addr username reldir (sshPubKey keypair)) secret {- Sends pairing messages until the thread is killed, - and shows an activity alert while doing it. - - - The button returns the user to the HomeR. This is + - The cancel button returns the user to the HomeR. This is - not ideal, but they have to be sent somewhere, and could - have been on a page specific to the in-process pairing - - that just stopped. + - that just stopped, so can't go back there. -} - sendrequests mkmsg dstatus homeurl = forkIO $ do + sendrequests sender dstatus homeurl = forkIO $ do tid <- myThreadId let selfdestruct = AlertButton { buttonLabel = "Cancel" , buttonUrl = homeurl - , buttonAction = Just $ const $ killThread tid + , buttonAction = Just $ const $ do + oncancel + killThread tid } - alertDuring dstatus (pairRequestAlert selfdestruct) $ do - _ <- E.try (multicastPairMsg mkmsg) :: IO (Either E.SomeException ()) + alertDuring dstatus (pairingAlert selfdestruct) $ do + _ <- E.try sender :: IO (Either E.SomeException ()) return () stopold = killThread . inProgressThreadId -#else -getStartPairR = noPairing -#endif - -getInprogressPairR :: Text -> Handler RepHtml -#ifdef WITH_PAIRING -getInprogressPairR secret = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" - $(widgetFile "configurators/pairing/inprogress") -#else -getInprogressPairR _ = noPairing -#endif -getFinishPairR :: PairMsg -> Handler RepHtml -#ifdef WITH_PAIRING -getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do - error "TODO" -#else -getFinishPairR _ = noPairing -#endif - -#ifdef WITH_PAIRING data InputSecret = InputSecret { secretText :: Maybe Text } +{- If a PairMsg is passed in, ensures that the user enters a secret + - that can validate it. -} promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml -promptSecret msg cont = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" +promptSecret msg cont = pairPage $ do ((result, form), enctype) <- lift $ runFormGet $ renderBootstrap $ InputSecret <$> aopt textField "Secret phrase" Nothing @@ -138,7 +177,7 @@ promptSecret msg cont = bootstrap (Just Config) $ do Just problem -> showform form enctype $ Just problem Just m -> - if verified (fromPairMsg m) secret + if verify (fromPairMsg m) secret then cont rawsecret secret else showform form enctype $ Just "That's not the right secret phrase." @@ -168,6 +207,15 @@ secretProblem s toSecret :: Text -> Secret toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s] +getUserName :: IO String +getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID) + +pairPage :: Widget -> Handler RepHtml +pairPage w = bootstrap (Just Config) $ do + sideBarDisplay + setTitle "Pairing" + w + {- From Dickens -} sampleQuote :: Text sampleQuote = T.unwords @@ -177,15 +225,10 @@ sampleQuote = T.unwords , "it was the age of foolishness." ] -getUserName :: IO String -getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID) - #else noPairing :: Handler RepHtml -noPairing = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" +noPairing = pairPage $ $(widgetFile "configurators/pairing/disabled") #endif diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index eebcdae03..3698c8370 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -49,7 +49,9 @@ mkSshData sshserver = SshData { sshHostName = fromMaybe "" $ hostname sshserver , sshUserName = username sshserver , sshDirectory = fromMaybe "" $ directory sshserver - , sshRepoName = genSshRepoName sshserver + , sshRepoName = genSshRepoName + (T.unpack $ fromJust $ hostname sshserver) + (maybe "" T.unpack $ directory sshserver) , needsPubKey = False , rsyncOnly = False } @@ -167,11 +169,6 @@ testServer sshserver = do genSshHost :: Text -> Maybe Text -> String genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host -{- host_dir -} -genSshRepoName :: SshServer -> String -genSshRepoName s = (T.unpack $ fromJust $ hostname s) ++ - (maybe "" (\d -> '_' : T.unpack d) (directory s)) - {- Runs a ssh command; if it fails shows the user the transcript, - and if it succeeds, runs an action. -} sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml @@ -211,11 +208,11 @@ makeSsh rsync sshdata | needsPubKey sshdata = do keypair <- liftIO $ genSshKeyPair sshdata' <- liftIO $ setupSshKeyPair keypair sshdata - makeSsh' rsync sshdata' (Just keypair) - | otherwise = makeSsh' rsync sshdata Nothing + makeSshWithKeyPair rsync sshdata' (Just keypair) + | otherwise = makeSshWithKeyPair rsync sshdata Nothing -makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml -makeSsh' rsync sshdata keypair = +makeSshWithKeyPair :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml +makeSshWithKeyPair rsync sshdata keypair = sshSetup [sshhost, remoteCommand] "" $ makeSshRepo rsync sshdata where @@ -226,7 +223,9 @@ makeSsh' rsync sshdata keypair = , Just $ "cd " ++ shellEscape remotedir , if rsync then Nothing else Just $ "git init --bare --shared" , if rsync then Nothing else Just $ "git annex init" - , maybe Nothing (makeAuthorizedKeys sshdata) keypair + , if needsPubKey sshdata + then maybe Nothing (Just . makeAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey) keypair + else Nothing ] makeSshRepo :: Bool -> SshData -> Handler RepHtml -- cgit v1.2.3