From d19bbd29d8f473eae1aa1fa76c22e5374922c108 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Sep 2012 21:55:59 -0400 Subject: pairing probably works now (untested) --- Assistant/WebApp/Configurators/Local.hs | 62 +++---------------------- Assistant/WebApp/Configurators/Pairing.hs | 67 +++++++-------------------- Assistant/WebApp/Configurators/Ssh.hs | 75 ++++++------------------------- 3 files changed, 37 insertions(+), 167 deletions(-) (limited to 'Assistant/WebApp/Configurators') diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 331130727..dd546881b 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -14,15 +14,12 @@ import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.SideBar import Assistant.Sync -import Assistant.DaemonStatus +import Assistant.MakeRemote import Utility.Yesod -import Remote.List -import qualified Remote import Init import qualified Git import qualified Git.Construct import qualified Git.Config -import qualified Git.Command import qualified Annex import Locations.UserConfig import Utility.FreeDesktop @@ -37,7 +34,6 @@ import qualified Data.Text as T import Data.Char import System.Posix.Directory import qualified Control.Exception as E -import Control.Concurrent data RepositoryPath = RepositoryPath Text deriving Show @@ -198,61 +194,15 @@ getAddDriveR = bootstrap (Just Config) $ do void $ makeGitRemote hostname hostlocation addRemote $ makeGitRemote name dir -{- Runs an action that returns a name of the remote, and finishes adding it. -} -addRemote :: Annex String -> Annex Remote -addRemote a = do - name <- a - void $ remoteListRefresh - maybe (error "failed to add remote") return =<< Remote.byName (Just name) - -{- Returns the name of the git remote it created. If there's already a - - remote at the location, returns its name. -} -makeGitRemote :: String -> String -> Annex String -makeGitRemote basename location = makeRemote basename location $ \name -> - void $ inRepo $ - Git.Command.runBool "remote" - [Param "add", Param name, Param location] - -{- If there's not already a remote at the location, adds it using the - - action, which is passed the name of the remote to make. - - - - Returns the name of the remote. -} -makeRemote :: String -> String -> (String -> Annex ()) -> Annex String -makeRemote basename location a = do - r <- fromRepo id - if (null $ filter samelocation $ Git.remotes r) - then do - let name = uniqueRemoteName r basename 0 - a name - return name - else return basename - where - samelocation x = Git.repoLocation x == location - -{- Generate an unused name for a remote, adding a number if - - necessary. -} -uniqueRemoteName :: Git.Repo -> String -> Int -> String -uniqueRemoteName r basename n - | null namecollision = name - | otherwise = uniqueRemoteName r basename (succ n) - where - namecollision = filter samename (Git.remotes r) - samename x = Git.remoteName x == Just name - name - | n == 0 = basename - | otherwise = basename ++ show n - {- Start syncing a newly added remote, using a background thread. -} syncRemote :: Remote -> Handler () syncRemote remote = do webapp <- getYesod - runAnnex () $ updateKnownRemotes (daemonStatus webapp) - void $ liftIO $ forkIO $ do - reconnectRemotes "WebApp" - (fromJust $ threadState webapp) - (daemonStatus webapp) - (scanRemotes webapp) - [remote] + liftIO $ syncNewRemote + (fromJust $ threadState webapp) + (daemonStatus webapp) + (scanRemotes webapp) + remote {- List of removable drives. -} driveList :: IO [RemovableDrive] diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 2e90eec36..4ff81c750 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -39,7 +39,6 @@ import Utility.Yesod import Assistant.Common import Assistant.Pairing.Network import Assistant.Ssh -import qualified Assistant.WebApp.Configurators.Ssh as Ssh import Assistant.Alert import Assistant.DaemonStatus import Utility.Verifiable @@ -60,9 +59,7 @@ import Control.Concurrent getStartPairR :: Handler RepHtml #ifdef WITH_PAIRING -getStartPairR = do - keypair <- liftIO genSshKeyPair - promptSecret Nothing $ startPairing PairReq keypair noop +getStartPairR = promptSecret Nothing $ startPairing PairReq noop #else getStartPairR = noPairing #endif @@ -70,44 +67,19 @@ getStartPairR = noPairing getFinishPairR :: PairMsg -> Handler RepHtml #ifdef WITH_PAIRING getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do - keypair <- setup - startPairing PairAck keypair cleanup "" secret + setup + startPairing PairAck cleanup "" secret where pubkey = remoteSshPubKey $ pairMsgData msg setup = do - validateSshPubKey pubKey + liftIO $ validateSshPubKey pubkey unlessM (liftIO $ makeAuthorizedKeys False pubkey) $ error "failed setting up ssh authorized keys" - keypair <- liftIO genSshKeyPair - sshdata <- liftIO $ pairMsgToSshData msg - 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 -{- Mostly a straightforward conversion. Except: - - * Determine the best hostname to use to contact the host. - - * Strip leading ~/ from the directory name. - -} -pairMsgToSshData :: PairMsg -> IO SshData -pairMsgToSshData msg = do - let d = pairMsgData msg - hostname <- liftIO $ bestHostName d - let dir = case remoteDirectory d of - ('~':'/':v) -> v - v -> v - return $ SshData - { sshHostName = T.pack hostname - , sshUserName = Just (T.pack $ remoteUserName d) - , sshDirectory = T.pack dir - , sshRepoName = genSshRepoName besthostname dir - , needsPubKey = True - , rsyncOnly = False - } - getInprogressPairR :: Text -> Handler RepHtml #ifdef WITH_PAIRING getInprogressPairR secret = pairPage $ do @@ -127,27 +99,23 @@ getInprogressPairR _ = noPairing - - Redirects to the pairing in progress page. -} -startPairing :: PairStage -> SshKeyPair -> IO () -> Text -> Secret -> Widget -startPairing stage keypair oncancel displaysecret secret = do +startPairing :: PairStage -> IO () -> Text -> Secret -> Widget +startPairing stage oncancel displaysecret secret = do + keypair <- liftIO $ genSshKeyPair dstatus <- daemonStatus <$> lift getYesod urlrender <- lift getUrlRender let homeurl = urlrender HomeR - sender <- mksender + pairdata <- PairData + <$> liftIO getHostname + <*> liftIO getUserName + <*> (fromJust . relDir <$> lift getYesod) + <*> pure (sshPubKey keypair) liftIO $ do - pip <- PairingInProgress secret - <$> sendrequests sender dstatus homeurl - <*> pure keypair - oldpip <- modifyDaemonStatus dstatus $ - \s -> (s { pairingInProgress = Just pip }, pairingInProgress s) - maybe noop stopold oldpip + let sender = multicastPairMsg Nothing secret stage pairdata + let pip = PairingInProgress secret Nothing keypair pairdata + startSending dstatus pip $ sendrequests sender dstatus homeurl 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. - @@ -156,7 +124,7 @@ startPairing stage keypair oncancel displaysecret secret = do - have been on a page specific to the in-process pairing - that just stopped, so can't go back there. -} - sendrequests sender dstatus homeurl = forkIO $ do + sendrequests sender dstatus homeurl = do tid <- myThreadId let selfdestruct = AlertButton { buttonLabel = "Cancel" @@ -168,7 +136,6 @@ startPairing stage keypair oncancel displaysecret secret = do alertDuring dstatus (pairingAlert selfdestruct) $ do _ <- E.try sender :: IO (Either E.SomeException ()) return () - stopold = killThread . inProgressThreadId data InputSecret = InputSecret { secretText :: Maybe Text } @@ -200,7 +167,7 @@ promptSecret msg cont = pairPage $ do let badphrase = isJust mproblem let problem = fromMaybe "" mproblem let (username, hostname) = maybe ("", "") - (\(_, v) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v))) + (\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v))) (verifiableVal . fromPairMsg <$> msg) u <- T.pack <$> liftIO getUserName let sameusername = username == u diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 3698c8370..f2e80ff5b 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -11,21 +11,15 @@ module Assistant.WebApp.Configurators.Ssh where import Assistant.Common import Assistant.Ssh +import Assistant.MakeRemote import Assistant.WebApp import Assistant.WebApp.Types import Assistant.WebApp.SideBar import Utility.Yesod -import Assistant.WebApp.Configurators.Local -import qualified Types.Remote as R -import qualified Remote.Rsync as Rsync -import qualified Command.InitRemote -import Logs.UUID -import Logs.Remote import Yesod import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Map as M import Network.BSD import System.Posix.User @@ -127,7 +121,7 @@ getAddSshR = sshConfigurator $ do testServer :: SshServer -> IO (ServerStatus, Bool) testServer (SshServer { hostname = Nothing }) = return (UnusableServer "Please enter a host name.", False) -testServer sshserver = do +testServer sshserver@(SshServer { hostname = Just hn }) = do status <- probe [sshOpt "NumberOfPasswordPrompts" "0"] if usable status then return (status, False) @@ -141,7 +135,7 @@ testServer sshserver = do , checkcommand "git-annex-shell" , checkcommand "rsync" ] - knownhost <- knownHost sshserver + knownhost <- knownHost hn let sshopts = filter (not . null) $ extraopts ++ {- If this is an already known host, let - ssh check it as usual. @@ -165,10 +159,6 @@ testServer sshserver = do token r = "git-annex-probe " ++ r report r = "echo " ++ token r -{- user@host or host -} -genSshHost :: Text -> Maybe Text -> String -genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host - {- 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 @@ -182,16 +172,6 @@ showSshErr :: String -> Handler RepHtml showSshErr msg = sshConfigurator $ $(widgetFile "configurators/ssh/error") -{- Does ssh have known_hosts data for a hostname? -} -knownHost :: SshServer -> IO Bool -knownHost (SshServer { hostname = Nothing }) = return False -knownHost (SshServer { hostname = Just h }) = do - sshdir <- sshDir - ifM (doesFileExist $ sshdir "known_hosts") - ( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack h] - , return False - ) - getConfirmSshR :: SshData -> Handler RepHtml getConfirmSshR sshdata = sshConfigurator $ do let authtoken = webAppFormAuthToken @@ -208,11 +188,11 @@ makeSsh rsync sshdata | needsPubKey sshdata = do keypair <- liftIO $ genSshKeyPair sshdata' <- liftIO $ setupSshKeyPair keypair sshdata - makeSshWithKeyPair rsync sshdata' (Just keypair) - | otherwise = makeSshWithKeyPair rsync sshdata Nothing + makeSsh' rsync sshdata' (Just keypair) + | otherwise = makeSsh' rsync sshdata Nothing -makeSshWithKeyPair :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml -makeSshWithKeyPair rsync sshdata keypair = +makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml +makeSsh' rsync sshdata keypair = sshSetup [sshhost, remoteCommand] "" $ makeSshRepo rsync sshdata where @@ -230,40 +210,13 @@ makeSshWithKeyPair rsync sshdata keypair = makeSshRepo :: Bool -> SshData -> Handler RepHtml makeSshRepo forcersync sshdata = do - r <- runAnnex undefined $ - addRemote $ maker (sshRepoName sshdata) sshurl - syncRemote r + webapp <- getYesod + liftIO $ makeSshRemote + (fromJust $ threadState webapp) + (daemonStatus webapp) + (scanRemotes webapp) + forcersync sshdata redirect RepositoriesR - where - rsync = forcersync || rsyncOnly sshdata - maker - | rsync = makeRsyncRemote - | otherwise = makeGitRemote - sshurl = T.unpack $ T.concat $ - if rsync - then [u, h, ":", sshDirectory sshdata, "/"] - else ["ssh://", u, h, d, "/"] - where - u = maybe "" (\v -> T.concat [v, "@"]) $ sshUserName sshdata - h = sshHostName sshdata - d - | "/" `T.isPrefixOf` sshDirectory sshdata = d - | otherwise = T.concat ["/~/", sshDirectory sshdata] - - -{- Inits a rsync special remote, and returns the name of the remote. -} -makeRsyncRemote :: String -> String -> Annex String -makeRsyncRemote name location = makeRemote name location $ const $ do - (u, c) <- Command.InitRemote.findByName name - c' <- R.setup Rsync.remote u $ M.union config c - describeUUID u name - configSet u c' - where - config = M.fromList - [ ("encryption", "shared") - , ("rsyncurl", location) - , ("type", "rsync") - ] getAddRsyncNetR :: Handler RepHtml getAddRsyncNetR = do @@ -276,7 +229,7 @@ getAddRsyncNetR = do $(widgetFile "configurators/addrsync.net") case result of FormSuccess sshserver -> do - knownhost <- liftIO $ knownHost sshserver + knownhost <- liftIO $ maybe (return False) knownHost (hostname sshserver) keypair <- liftIO $ genSshKeyPair sshdata <- liftIO $ setupSshKeyPair keypair (mkSshData sshserver) -- cgit v1.2.3