pairing probably works now (untested)

This commit is contained in:
Joey Hess 2012-09-10 21:55:59 -04:00
parent a41255723c
commit d19bbd29d8
11 changed files with 323 additions and 229 deletions

View file

@ -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]

View file

@ -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

View file

@ -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)