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
|
|
@ -181,7 +181,7 @@ startAssistant assistant daemonize webappwaiter = do
|
|||
#ifdef WITH_WEBAPP
|
||||
, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots urlrenderer Nothing webappwaiter
|
||||
#ifdef WITH_PAIRING
|
||||
, assist $ pairListenerThread st dstatus urlrenderer
|
||||
, assist $ pairListenerThread st dstatus scanremotes urlrenderer
|
||||
#endif
|
||||
#endif
|
||||
, assist $ pushThread st dstatus commitchan pushmap
|
||||
|
|
|
|||
107
Assistant/MakeRemote.hs
Normal file
107
Assistant/MakeRemote.hs
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
{- git-annex assistant remote creation utilities
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.MakeRemote where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.Ssh
|
||||
import Assistant.Sync
|
||||
import qualified Types.Remote as R
|
||||
import qualified Remote
|
||||
import Remote.List
|
||||
import qualified Remote.Rsync as Rsync
|
||||
import qualified Git
|
||||
import qualified Git.Command
|
||||
import qualified Command.InitRemote
|
||||
import Logs.UUID
|
||||
import Logs.Remote
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
|
||||
{- Sets up and begins syncing with a new ssh or rsync remote. -}
|
||||
makeSshRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Bool -> SshData -> IO ()
|
||||
makeSshRemote st dstatus scanremotes forcersync sshdata = do
|
||||
r <- runThreadState st $
|
||||
addRemote $ maker (sshRepoName sshdata) sshurl
|
||||
syncNewRemote st dstatus scanremotes r
|
||||
where
|
||||
rsync = forcersync || rsyncOnly sshdata
|
||||
maker
|
||||
| rsync = makeRsyncRemote
|
||||
| otherwise = makeGitRemote
|
||||
sshurl = T.unpack $ T.concat $
|
||||
if rsync
|
||||
then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"]
|
||||
else [T.pack "ssh://", u, h, d, T.pack "/"]
|
||||
where
|
||||
u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
|
||||
h = sshHostName sshdata
|
||||
d
|
||||
| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = d
|
||||
| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
|
||||
|
||||
{- 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)
|
||||
|
||||
{- 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")
|
||||
]
|
||||
|
||||
{- 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
|
||||
|
|
@ -25,23 +25,24 @@ data PairStage
|
|||
| PairDone
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
newtype PairMsg = PairMsg (Verifiable (PairStage, PairData))
|
||||
newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData))
|
||||
fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData, SomeAddr))
|
||||
fromPairMsg (PairMsg m) = m
|
||||
|
||||
pairMsgStage :: PairMsg -> PairStage
|
||||
pairMsgStage (PairMsg (Verifiable (s, _) _)) = s
|
||||
pairMsgStage (PairMsg (Verifiable (s, _, _) _)) = s
|
||||
|
||||
pairMsgData :: PairMsg -> PairData
|
||||
pairMsgData (PairMsg (Verifiable (_, d) _)) = d
|
||||
pairMsgData (PairMsg (Verifiable (_, d, _) _)) = d
|
||||
|
||||
pairMsgAddr :: PairMsg -> SomeAddr
|
||||
pairMsgAddr (PairMsg (Verifiable (_, _, a) _)) = a
|
||||
|
||||
data PairData = PairData
|
||||
-- uname -n output, not a full domain name
|
||||
{ remoteHostName :: Maybe HostName
|
||||
-- the address is included so that it can be verified, avoiding spoofing
|
||||
, remoteAddress :: SomeAddr
|
||||
, remoteUserName :: UserName
|
||||
, remoteDirectory :: FilePath
|
||||
, remoteSshPubKey :: SshPubKey
|
||||
|
|
@ -55,8 +56,9 @@ type UserName = String
|
|||
- set up on disk. -}
|
||||
data PairingInProgress = PairingInProgress
|
||||
{ inProgressSecret :: Secret
|
||||
, inProgressThreadId :: ThreadId
|
||||
, inProgressThreadId :: Maybe ThreadId
|
||||
, inProgressSshKeyPair :: SshKeyPair
|
||||
, inProgressPairData :: PairData
|
||||
}
|
||||
|
||||
data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6
|
||||
|
|
|
|||
81
Assistant/Pairing/MakeRemote.hs
Normal file
81
Assistant/Pairing/MakeRemote.hs
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
{- git-annex assistant pairing remote creation
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.Pairing.MakeRemote where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.Ssh
|
||||
import Assistant.Pairing
|
||||
import Assistant.Pairing.Network
|
||||
import Assistant.MakeRemote
|
||||
|
||||
import Network.Socket
|
||||
import qualified Data.Text as T
|
||||
|
||||
{- When pairing is complete, this is used to set up the remote for the host
|
||||
- we paired with. -}
|
||||
finishedPairing :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> SshKeyPair -> IO ()
|
||||
finishedPairing st dstatus scanremotes msg keypair = do
|
||||
sshdata <- setupSshKeyPair keypair =<< pairMsgToSshData msg
|
||||
{- Ensure that we know
|
||||
- the ssh host key for the host we paired with.
|
||||
- If we don't, ssh over to get it. -}
|
||||
unlessM (knownHost $ sshHostName sshdata) $ do
|
||||
void $ sshTranscript
|
||||
[ sshOpt "StrictHostKeyChecking" "no"
|
||||
, sshOpt "NumberOfPasswordPrompts" "0"
|
||||
, "-n"
|
||||
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||||
, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
|
||||
]
|
||||
""
|
||||
makeSshRemote st dstatus scanremotes False sshdata
|
||||
|
||||
{- 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 msg
|
||||
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 hostname dir
|
||||
, needsPubKey = True
|
||||
, rsyncOnly = False
|
||||
}
|
||||
|
||||
{- Finds the best hostname to use for the host that sent the PairMsg.
|
||||
-
|
||||
- If remoteHostName is set, tries to use a .local address based on it.
|
||||
- That's the most robust, if this system supports .local.
|
||||
- Otherwise, looks up the hostname in the DNS for the remoteAddress,
|
||||
- if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
|
||||
bestHostName :: PairMsg -> IO HostName
|
||||
bestHostName msg = case (remoteHostName $ pairMsgData msg) of
|
||||
Just h -> do
|
||||
let localname = h ++ ".local"
|
||||
addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
|
||||
maybe fallback (const $ return localname) (headMaybe addrs)
|
||||
Nothing -> fallback
|
||||
where
|
||||
fallback = do
|
||||
let a = pairMsgAddr msg
|
||||
let sockaddr = case a of
|
||||
IPv4Addr addr -> SockAddrInet (PortNum 0) addr
|
||||
IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
|
||||
fromMaybe (showAddr a)
|
||||
<$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
|
||||
|
|
@ -1,4 +1,8 @@
|
|||
{- git-annex assistant pairing network code
|
||||
-
|
||||
- All network traffic is sent over multicast UDP. For reliability,
|
||||
- each message is repeated until acknowledged. This is done using a
|
||||
- thread, that gets stopped before the next message is sent.
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
|
|
@ -7,15 +11,18 @@
|
|||
|
||||
module Assistant.Pairing.Network where
|
||||
|
||||
import Common
|
||||
import Assistant.Common
|
||||
import Assistant.Pairing
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.ThreadScheduler
|
||||
import Utility.Verifiable
|
||||
|
||||
import Network.Multicast
|
||||
import Network.Info
|
||||
import Network.Socket
|
||||
import Control.Exception (bracket)
|
||||
import qualified Data.Map as M
|
||||
import Control.Concurrent
|
||||
|
||||
{- This is an arbitrary port in the dynamic port range, that could
|
||||
- conceivably be used for some other broadcast messages.
|
||||
|
|
@ -30,8 +37,9 @@ multicastAddress :: SomeAddr -> HostName
|
|||
multicastAddress (IPv4Addr _) = "224.0.0.1"
|
||||
multicastAddress (IPv6Addr _) = "ff02::1"
|
||||
|
||||
{- Multicasts a message repeatedly on all interfaces forever, until killed
|
||||
- with a 2 second delay between each transmission.
|
||||
{- Multicasts a message repeatedly on all interfaces, with a 2 second
|
||||
- delay between each transmission. The message is repeated forever
|
||||
- unless a number of repeats is specified.
|
||||
-
|
||||
- The remoteHostAddress is set to the interface's IP address.
|
||||
-
|
||||
|
|
@ -39,15 +47,16 @@ multicastAddress (IPv6Addr _) = "ff02::1"
|
|||
- but it allows new network interfaces to be used as they come up.
|
||||
- On the other hand, the expensive DNS lookups are cached.
|
||||
-}
|
||||
multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ()
|
||||
multicastPairMsg mkmsg = go M.empty
|
||||
multicastPairMsg :: Maybe Int -> Secret -> PairStage -> PairData -> IO ()
|
||||
multicastPairMsg repeats secret stage pairdata = go M.empty repeats
|
||||
where
|
||||
go cache = do
|
||||
go _ (Just 0) = noop
|
||||
go cache n = do
|
||||
addrs <- activeNetworkAddresses
|
||||
let cache' = updatecache cache addrs
|
||||
mapM_ (sendinterface cache') addrs
|
||||
threadDelaySeconds (Seconds 2)
|
||||
go cache'
|
||||
go cache' $ pred <$> n
|
||||
sendinterface cache i = void $ catchMaybeIO $
|
||||
withSocketsDo $ bracket
|
||||
(multicastSender (multicastAddress i) pairingPort)
|
||||
|
|
@ -61,27 +70,23 @@ multicastPairMsg mkmsg = go M.empty
|
|||
updatecache cache (i:is)
|
||||
| M.member i cache = updatecache cache is
|
||||
| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
|
||||
mkmsg addr = PairMsg $
|
||||
mkVerifiable (stage, pairdata, addr) secret
|
||||
|
||||
{- Finds the best hostname to use for the host that sent the PairData.
|
||||
-
|
||||
- If remoteHostName is set, tries to use a .local address based on it.
|
||||
- That's the most robust, if this system supports .local.
|
||||
- Otherwise, looks up the hostname in the DNS for the remoteAddress,
|
||||
- if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
|
||||
bestHostName :: PairData -> IO HostName
|
||||
bestHostName d = case remoteHostName d of
|
||||
Just h -> do
|
||||
let localname = h ++ ".local"
|
||||
addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
|
||||
maybe fallback (const $ return localname) (headMaybe addrs)
|
||||
Nothing -> fallback
|
||||
startSending :: DaemonStatusHandle -> PairingInProgress -> IO () -> IO ()
|
||||
startSending dstatus pip sender = do
|
||||
tid <- forkIO sender
|
||||
let pip' = pip { inProgressThreadId = Just tid }
|
||||
oldpip <- modifyDaemonStatus dstatus $
|
||||
\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
|
||||
maybe noop stopold oldpip
|
||||
where
|
||||
fallback = do
|
||||
let sockaddr = case remoteAddress d of
|
||||
IPv4Addr a -> SockAddrInet (PortNum 0) a
|
||||
IPv6Addr a -> SockAddrInet6 (PortNum 0) 0 a 0
|
||||
fromMaybe (show $ remoteAddress d)
|
||||
<$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
|
||||
stopold = maybe noop killThread . inProgressThreadId
|
||||
|
||||
stopSending :: DaemonStatusHandle -> PairingInProgress -> IO ()
|
||||
stopSending dstatus pip = do
|
||||
maybe noop killThread $ inProgressThreadId pip
|
||||
modifyDaemonStatus_ dstatus $ \s -> s { pairingInProgress = Nothing }
|
||||
|
||||
class ToSomeAddr a where
|
||||
toSomeAddr :: a -> SomeAddr
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
module Assistant.Ssh where
|
||||
|
||||
import Common
|
||||
import Common.Annex
|
||||
import Utility.TempFile
|
||||
|
||||
import Data.Text (Text)
|
||||
|
|
@ -43,6 +43,10 @@ sshDir = do
|
|||
home <- myHomeDir
|
||||
return $ home </> ".ssh"
|
||||
|
||||
{- user@host or host -}
|
||||
genSshHost :: Text -> Maybe Text -> String
|
||||
genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
|
||||
|
||||
{- host_dir, with all / in dir replaced by _, and bad characters removed -}
|
||||
genSshRepoName :: String -> FilePath -> String
|
||||
genSshRepoName host dir
|
||||
|
|
@ -171,3 +175,12 @@ setupSshKeyPair sshkeypair sshdata = do
|
|||
sshpubkeyfile = sshprivkeyfile ++ ".pub"
|
||||
mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
|
||||
user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
|
||||
|
||||
{- Does ssh have known_hosts data for a hostname? -}
|
||||
knownHost :: Text -> IO Bool
|
||||
knownHost hostname = do
|
||||
sshdir <- sshDir
|
||||
ifM (doesFileExist $ sshdir </> "known_hosts")
|
||||
( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack hostname]
|
||||
, return False
|
||||
)
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import qualified Annex.Branch
|
|||
|
||||
import Data.Time.Clock
|
||||
import qualified Data.Map as M
|
||||
import Control.Concurrent
|
||||
|
||||
{- Syncs with remotes that may have been disconnected for a while.
|
||||
-
|
||||
|
|
@ -108,3 +109,9 @@ manualPull st currentbranch remotes = do
|
|||
forM_ remotes $ \r ->
|
||||
runThreadState st $ Command.Sync.mergeRemote r currentbranch
|
||||
return haddiverged
|
||||
|
||||
{- Start syncing a newly added remote, using a background thread. -}
|
||||
syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
|
||||
syncNewRemote st dstatus scanremotes remote = do
|
||||
runThreadState st $ updateKnownRemotes dstatus
|
||||
void $ forkIO $ do reconnectRemotes "SyncRemote" st dstatus scanremotes [remote]
|
||||
|
|
|
|||
|
|
@ -10,7 +10,9 @@ module Assistant.Threads.PairListener where
|
|||
import Assistant.Common
|
||||
import Assistant.Pairing
|
||||
import Assistant.Pairing.Network
|
||||
import Assistant.Pairing.MakeRemote
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.Types
|
||||
|
|
@ -25,8 +27,8 @@ import qualified Data.Text as T
|
|||
thisThread :: ThreadName
|
||||
thisThread = "PairListener"
|
||||
|
||||
pairListenerThread :: ThreadState -> DaemonStatusHandle -> UrlRenderer -> NamedThread
|
||||
pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
|
||||
pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread
|
||||
pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do
|
||||
sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
|
||||
go sock
|
||||
where
|
||||
|
|
@ -47,15 +49,16 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
|
|||
|
||||
dispatch Nothing = noop
|
||||
dispatch (Just m@(PairMsg v)) = do
|
||||
verified <- maybe False (verify v . inProgressSecret)
|
||||
. pairingInProgress
|
||||
<$> getDaemonStatus dstatus
|
||||
pip <- pairingInProgress <$> getDaemonStatus dstatus
|
||||
let verified = maybe False (verify v . inProgressSecret) pip
|
||||
case pairMsgStage m of
|
||||
PairReq -> pairReqReceived verified dstatus urlrenderer m
|
||||
PairAck -> pairAckReceived verified dstatus m
|
||||
PairDone -> pairDoneReceived verified dstatus m
|
||||
PairAck -> pairAckReceived verified pip st dstatus scanremotes m
|
||||
PairDone -> pairDoneReceived verified pip st dstatus scanremotes m
|
||||
|
||||
{- Pair request alerts from the same host combine,
|
||||
{- Show an alert when a PairReq is seen.
|
||||
-
|
||||
- Pair request alerts from the same host combine,
|
||||
- so repeated requests do not add additional alerts. -}
|
||||
pairReqReceived :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
|
||||
pairReqReceived True _ _ _ = noop -- ignore out own PairReq
|
||||
|
|
@ -69,12 +72,11 @@ pairReqReceived False dstatus urlrenderer msg = do
|
|||
, buttonAction = Just onclick
|
||||
}
|
||||
where
|
||||
v = fromPairMsg msg
|
||||
(_, pairdata) = verifiableVal v
|
||||
pairdata = pairMsgData msg
|
||||
repo = concat
|
||||
[ remoteUserName pairdata
|
||||
, "@"
|
||||
, fromMaybe (showAddr $ remoteAddress pairdata)
|
||||
, fromMaybe (showAddr $ pairMsgAddr msg)
|
||||
(remoteHostName pairdata)
|
||||
, ":"
|
||||
, (remoteDirectory pairdata)
|
||||
|
|
@ -90,27 +92,34 @@ pairReqReceived False dstatus urlrenderer msg = do
|
|||
, alertData = [UnTensed $ T.pack $ "pair request with " ++ repo ++ " in progress"]
|
||||
}
|
||||
|
||||
{- When a valid PairAck is seen, a host has successfully paired with
|
||||
- us, and we should finish pairing with them. Then send a single PairDone.
|
||||
{- When a verified PairAck is seen, a host is ready to pair with us, and has
|
||||
- already configured our ssh key. Stop sending PairReqs, finish the pairing,
|
||||
- and send a few PairDones.
|
||||
-
|
||||
- A stale PairAck might also be seen, after we've finished pairing.
|
||||
- TODO: A stale PairAck might also be seen, after we've finished pairing.
|
||||
- Perhaps our PairDone was not received. To handle this, we keep
|
||||
- a list of recently finished pairings, and re-send PairDone in
|
||||
- response to stale PairAcks for them.
|
||||
-}
|
||||
pairAckReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO ()
|
||||
pairAckReceived False _ _ = noop -- not verified
|
||||
pairAckReceived True dstatus msg = error "TODO"
|
||||
pairAckReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
|
||||
pairAckReceived False _ _ _ _ _ = noop -- not verified
|
||||
pairAckReceived True Nothing _ _ _ _ = noop -- not in progress
|
||||
pairAckReceived True (Just pip) st dstatus scanremotes msg = do
|
||||
stopSending dstatus pip
|
||||
finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
|
||||
startSending dstatus pip $ multicastPairMsg
|
||||
(Just 10) (inProgressSecret pip) PairDone (inProgressPairData pip)
|
||||
|
||||
{- If we get a valid PairDone, and are sending PairAcks, we can stop
|
||||
- sending them, as the message has been received.
|
||||
{- If we get a verified PairDone, the host has accepted our PairAck, and
|
||||
- has paired with us. Stop sending PairAcks, and finish pairing with them.
|
||||
-
|
||||
- Also, now is the time to remove the pair request alert, as pairing is
|
||||
- over. Do that even if the PairDone cannot be validated, as we might
|
||||
- be a third host that did not participate in the pairing.
|
||||
- Note: This does allow a bad actor to squelch pairing on a network
|
||||
- by sending bogus PairDones.
|
||||
- TODO: Should third-party hosts remove their pair request alert when they
|
||||
- see a PairDone? How to tell if a PairDone matches with the PairReq
|
||||
- that brought up the alert? Cannot verify it without the secret..
|
||||
-}
|
||||
pairDoneReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO ()
|
||||
pairDoneReceived False _ _ = noop -- not verified
|
||||
pairDoneReceived True dstatus msg = error "TODO"
|
||||
pairDoneReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
|
||||
pairDoneReceived False _ _ _ _ _ = noop -- not verified
|
||||
pairDoneReceived True Nothing _ _ _ _ = noop -- not in progress
|
||||
pairDoneReceived True (Just pip) st dstatus scanremotes msg = do
|
||||
stopSending dstatus pip
|
||||
finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
|
||||
|
|
|
|||
|
|
@ -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…
Reference in a new issue