summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/MakeRemote.hs107
-rw-r--r--Assistant/Pairing.hs16
-rw-r--r--Assistant/Pairing/MakeRemote.hs81
-rw-r--r--Assistant/Pairing/Network.hs57
-rw-r--r--Assistant/Ssh.hs15
-rw-r--r--Assistant/Sync.hs7
-rw-r--r--Assistant/Threads/PairListener.hs63
-rw-r--r--Assistant/WebApp/Configurators/Local.hs62
-rw-r--r--Assistant/WebApp/Configurators/Pairing.hs67
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs75
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)