diff options
Diffstat (limited to 'Assistant/WebApp/Configurators/Ssh.hs')
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 75 |
1 files changed, 14 insertions, 61 deletions
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) |