pairing probably works now (untested)
This commit is contained in:
Joey Hess
parent
a41255723c
commit
d19bbd29d8
11 changed files with 323 additions and 229 deletions
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue