diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/MakeRemote.hs | 107 | ||||
| -rw-r--r-- | Assistant/Pairing.hs | 16 | ||||
| -rw-r--r-- | Assistant/Pairing/MakeRemote.hs | 81 | ||||
| -rw-r--r-- | Assistant/Pairing/Network.hs | 57 | ||||
| -rw-r--r-- | Assistant/Ssh.hs | 15 | ||||
| -rw-r--r-- | Assistant/Sync.hs | 7 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 63 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Local.hs | 62 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 67 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 75 |
10 files changed, 322 insertions, 228 deletions
diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs new file mode 100644 index 000000000..1b3e6dd7d --- /dev/null +++ b/Assistant/MakeRemote.hs @@ -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 diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index b957e0835..4aade5465 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -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 diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs new file mode 100644 index 000000000..9e65f4d13 --- /dev/null +++ b/Assistant/Pairing/MakeRemote.hs @@ -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 diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 8832db05f..2afbf1f56 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -1,5 +1,9 @@ {- 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> - - Licensed under the GNU GPL version 3 or higher. @@ -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 diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index c158f7dd2..ad0749fb7 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -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 + ) diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 42863f858..4a9cae767 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -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] diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 8b1cac2ba..e0ed1217a 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -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) 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) |