diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 334ee08079..357e049bbf 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -25,9 +25,11 @@ import Yesod
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
+import qualified Control.Exception as E
import Network.BSD
import System.Posix.User
import System.Process (CreateProcess(..))
+import Control.Concurrent
sshConfigurator :: Widget -> Handler RepHtml
sshConfigurator a = bootstrap (Just Config) $ do
@@ -42,6 +44,18 @@ data SshServer = SshServer
}
deriving (Show)
+{- SshServer is only used for applicative form prompting, this converts
+ - the result of such a form into a SshData. -}
+mkSshData :: SshServer -> SshData
+mkSshData sshserver = SshData
+ { sshHostName = fromMaybe "" $ hostname sshserver
+ , sshUserName = username sshserver
+ , sshDirectory = fromMaybe "" $ directory sshserver
+ , sshRepoName = genSshRepoName sshserver
+ , needsPubKey = False
+ , rsyncOnly = False
+ }
+
sshServerAForm :: (Maybe Text) -> AForm WebApp WebApp SshServer
sshServerAForm localusername = SshServer
<$> aopt check_hostname "Host name" Nothing
@@ -89,12 +103,8 @@ getAddSshR = sshConfigurator $ do
(status, needspubkey) <- liftIO $ testServer sshserver
if usable status
then lift $ redirect $ ConfirmSshR $
- SshData
- { sshHostName = fromJust $ hostname sshserver
- , sshUserName = username sshserver
- , sshDirectory = fromMaybe "" $ directory sshserver
- , sshRepoName = genSshRepoName sshserver
- , needsPubKey = needspubkey
+ (mkSshData sshserver)
+ { needsPubKey = needspubkey
, rsyncOnly = (status == UsableRsyncServer)
}
else showform form enctype status
@@ -112,36 +122,36 @@ getAddSshR = sshConfigurator $ do
- a special ssh key will need to be generated just for this server.
-
- Once logged into the server, probe to see if git-annex-shell is
- - available, or rsync.
+ - available, or rsync.\
-}
testServer :: SshServer -> IO (ServerStatus, Bool)
testServer (SshServer { hostname = Nothing }) = return
(UnusableServer "Please enter a host name.", False)
testServer sshserver = do
- status <- probe sshserver [sshopt "NumberOfPasswordPrompts" "0"]
+ status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
if usable status
then return (status, False)
else do
- status' <- probe sshserver []
+ status' <- probe []
return (status', True)
where
- probe s extraopts = do
- knownhost <- knownHost sshserver
+ probe extraopts = do
let remotecommand = join ";" $
[ report "loggedin"
, checkcommand "git-annex-shell"
, checkcommand "rsync"
]
- let sshopts = nonempty $ extraopts ++
+ knownhost <- knownHost sshserver
+ let sshopts = filter (not . null) $ extraopts ++
{- If this is an already known host, let
- ssh check it as usual.
- Otherwise, trust the host key. -}
- [ if knownhost then "" else sshopt "StrictHostKeyChecking" "no"
+ [ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
, "-n" -- don't read from stdin
- , genSshHost (fromJust $ hostname s) (username s)
+ , genSshHost (fromJust $ hostname sshserver) (username sshserver)
, remotecommand
]
- parsetranscript . fst <$> sshTranscript sshopts
+ parsetranscript . fst <$> sshTranscript sshopts ""
parsetranscript s
| reported "git-annex-shell" = UsableSshServer
| reported "rsync" = UsableRsyncServer
@@ -151,11 +161,13 @@ testServer sshserver = do
"Failed to ssh to the server. Transcript: " ++ s
where
reported r = token r `isInfixOf` s
- nonempty = filter $ not . null
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
token r = "git-annex-probe " ++ r
report r = "echo " ++ token r
- sshopt k v = concat ["-o", k, "=", v]
+
+{- ssh -ofoo=bar command-line option -}
+sshOpt :: String -> String -> String
+sshOpt k v = concat ["-o", k, "=", v]
sshDir :: IO FilePath
sshDir = do
@@ -172,23 +184,49 @@ genSshRepoName s = (T.unpack $ fromJust $ hostname s) ++
(maybe "" (\d -> '_' : T.unpack d) (directory s))
{- The output of ssh, including both stdout and stderr. -}
-sshTranscript :: [String] -> IO (String, Bool)
-sshTranscript opts = do
+sshTranscript :: [String] -> String -> IO (String, Bool)
+sshTranscript opts input = do
(readf, writef) <- createPipe
readh <- fdToHandle readf
writeh <- fdToHandle writef
- (_, _, _, pid) <- createProcess $
+ (Just inh, _, _, pid) <- createProcess $
(proc "ssh" opts)
- { std_in = Inherit
+ { std_in = CreatePipe
, std_out = UseHandle writeh
, std_err = UseHandle writeh
}
hClose writeh
- transcript <- hGetContentsStrict readh
+
+ -- fork off a thread to start consuming the output
+ transcript <- hGetContents readh
+ outMVar <- newEmptyMVar
+ _ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
+
+ -- now write and flush any input
+ when (not (null input)) $ do hPutStr inh input; hFlush inh
+ hClose inh -- done with stdin
+
+ -- wait on the output
+ takeMVar outMVar
hClose readh
+
ok <- checkSuccessProcess pid
+ return ()
return (transcript, ok)
+{- 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
+sshSetup opts input a = do
+ (transcript, ok) <- liftIO $ sshTranscript opts input
+ if ok
+ then a
+ else showSshErr transcript
+
+showSshErr :: String -> Handler RepHtml
+showSshErr msg = sshConfigurator $
+ $(widgetFile "configurators/makessherror")
+
{- Does ssh have known_hosts data for a hostname? -}
knownHost :: SshServer -> IO Bool
knownHost (SshServer { hostname = Nothing }) = return False
@@ -218,14 +256,9 @@ makeSsh rsync sshdata
| otherwise = makeSsh' rsync sshdata Nothing
makeSsh' :: Bool -> SshData -> Maybe String -> Handler RepHtml
-makeSsh' rsync sshdata pubkey = do
- (transcript, ok) <- liftIO $ sshTranscript [sshhost, remoteCommand]
- if ok
- then do
- r <- runAnnex undefined makerepo
- syncRemote r
- redirect RepositoriesR
- else showerr transcript
+makeSsh' rsync sshdata pubkey =
+ sshSetup [sshhost, remoteCommand] "" $
+ makeSshRepo rsync sshdata
where
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
remotedir = T.unpack $ sshDirectory sshdata
@@ -236,22 +269,29 @@ makeSsh' rsync sshdata pubkey = do
, if rsync then Nothing else Just $ "git annex init"
, maybe Nothing (makeAuthorizedKeys sshdata) pubkey
]
- showerr msg = sshConfigurator $
- $(widgetFile "configurators/makessherror")
- {- This is a one-sided remote setup; the remote server
- - probably does not have a route to the client here. -}
- makerepo = addRemote $
- (if rsync then makeRsyncRemote else makeGitRemote)
- (sshRepoName sshdata) sshurl
- sshurl = T.unpack $ T.concat $ if rsync
- then [u, h, ":", sshDirectory sshdata, "/"]
- else ["ssh://", u, h, d, "/"]
+
+makeSshRepo :: Bool -> SshData -> Handler RepHtml
+makeSshRepo forcersync sshdata = do
+ r <- runAnnex undefined $
+ addRemote $ maker (sshRepoName sshdata) sshurl
+ syncRemote r
+ 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
@@ -322,19 +362,48 @@ genSshKey sshdata = do
user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
getAddRsyncNetR :: Handler RepHtml
-getAddRsyncNetR = bootstrap (Just Config) $ do
- sideBarDisplay
- setTitle "Add a Rsync.net repository"
- ((result, form), enctype) <- lift $
- runFormGet $ renderBootstrap $ sshServerAForm Nothing
- let showform status = do
+getAddRsyncNetR = do
+ ((result, form), enctype) <- runFormGet $
+ renderBootstrap $ sshServerAForm Nothing
+ let showform status = bootstrap (Just Config) $ do
+ sideBarDisplay
+ setTitle "Add a Rsync.net repository"
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/addrsync.net")
case result of
FormSuccess sshserver -> do
+ knownhost <- liftIO $ knownHost sshserver
+ (pubkey, sshdata) <- liftIO $ genSshKey $
+ (mkSshData sshserver)
+ { needsPubKey = True
+ , rsyncOnly = True
+ , sshRepoName = "rsync.net"
+ }
+ {- I'd prefer to separate commands with && , but
+ - rsync.net's shell does not support that.
+ -
+ - The dd method of appending to the
+ - authorized_keys file is the one recommended by
+ - rsync.net documentation. I touch the file first
+ - to not need to use a different method to create
+ - it.
+ -}
+ let remotecommand = join ";" $
+ [ "mkdir -p .ssh"
+ , "touch .ssh/authorized_keys"
+ , "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
+ , "mkdir -p " ++ T.unpack (sshDirectory sshdata)
+ ]
+ let sshopts = filter (not . null) $
+ [ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
+ , genSshHost (sshHostName sshdata) (sshUserName sshdata)
+ , remotecommand
+ ]
+
let host = fromMaybe "" $ hostname sshserver
- checkhost host showform $ do
- error "TODO"
+ checkhost host showform $
+ sshSetup sshopts pubkey $
+ makeSshRepo True sshdata
_ -> showform UntestedServer
where
checkhost host showform a
diff --git a/templates/configurators/addrsync.net.hamlet b/templates/configurators/addrsync.net.hamlet
index 163d0721ee..6ea55ae129 100644
--- a/templates/configurators/addrsync.net.hamlet
+++ b/templates/configurators/addrsync.net.hamlet
@@ -40,4 +40,4 @@
Setting up your rsync.net repository. This could take a minute.
- You may be prompted for your rsync.net password.
+ You may be prompted for your rsync.net ssh password.