2012-08-31 19:17:12 +00:00
|
|
|
|
{- git-annex assistant webapp configurator for ssh-based remotes
|
|
|
|
|
-
|
2014-05-01 01:27:17 +00:00
|
|
|
|
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
|
2012-08-31 19:17:12 +00:00
|
|
|
|
-
|
2012-09-24 18:48:47 +00:00
|
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2012-08-31 19:17:12 +00:00
|
|
|
|
-}
|
|
|
|
|
|
2013-06-05 01:02:09 +00:00
|
|
|
|
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
2013-05-04 18:25:30 +00:00
|
|
|
|
{-# LANGUAGE CPP #-}
|
2012-08-31 19:17:12 +00:00
|
|
|
|
|
|
|
|
|
module Assistant.WebApp.Configurators.Ssh where
|
|
|
|
|
|
2012-11-25 04:26:46 +00:00
|
|
|
|
import Assistant.WebApp.Common
|
2013-09-26 20:09:45 +00:00
|
|
|
|
import Assistant.WebApp.Gpg
|
2012-09-10 19:20:18 +00:00
|
|
|
|
import Assistant.Ssh
|
2013-10-28 15:33:14 +00:00
|
|
|
|
import Assistant.WebApp.MakeRemote
|
2012-09-13 20:47:44 +00:00
|
|
|
|
import Logs.Remote
|
|
|
|
|
import Remote
|
2012-10-10 20:04:28 +00:00
|
|
|
|
import Types.StandardGroups
|
2012-10-25 22:17:32 +00:00
|
|
|
|
import Utility.UserInfo
|
2013-09-26 20:09:45 +00:00
|
|
|
|
import Utility.Gpg
|
2013-10-01 20:08:01 +00:00
|
|
|
|
import Types.Remote (RemoteConfig)
|
2013-11-07 22:02:00 +00:00
|
|
|
|
import Git.Types (RemoteName)
|
2013-09-27 20:21:56 +00:00
|
|
|
|
import qualified Remote.GCrypt as GCrypt
|
2013-10-02 19:54:32 +00:00
|
|
|
|
import Annex.UUID
|
|
|
|
|
import Logs.UUID
|
2014-04-20 19:30:39 +00:00
|
|
|
|
import Assistant.RemoteControl
|
2012-08-31 19:17:12 +00:00
|
|
|
|
|
2014-02-14 19:42:35 +00:00
|
|
|
|
#ifdef mingw32_HOST_OS
|
|
|
|
|
import Utility.Tmp
|
|
|
|
|
import Utility.Rsync
|
|
|
|
|
#endif
|
|
|
|
|
|
2012-08-31 19:17:12 +00:00
|
|
|
|
import qualified Data.Text as T
|
2012-09-13 20:47:44 +00:00
|
|
|
|
import qualified Data.Map as M
|
2012-09-29 16:49:23 +00:00
|
|
|
|
import Network.Socket
|
2013-09-26 20:09:45 +00:00
|
|
|
|
import Data.Ord
|
2012-08-31 19:17:12 +00:00
|
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
|
sshConfigurator :: Widget -> Handler Html
|
2012-12-30 03:10:18 +00:00
|
|
|
|
sshConfigurator = page "Add a remote server" (Just Configuration)
|
2012-09-02 19:21:40 +00:00
|
|
|
|
|
2012-09-13 20:47:44 +00:00
|
|
|
|
data SshInput = SshInput
|
2012-12-06 21:09:08 +00:00
|
|
|
|
{ inputHostname :: Maybe Text
|
|
|
|
|
, inputUsername :: Maybe Text
|
|
|
|
|
, inputDirectory :: Maybe Text
|
|
|
|
|
, inputPort :: Int
|
2012-08-31 22:59:57 +00:00
|
|
|
|
}
|
2012-09-02 04:27:48 +00:00
|
|
|
|
deriving (Show)
|
2012-09-02 01:10:40 +00:00
|
|
|
|
|
2012-09-13 20:47:44 +00:00
|
|
|
|
{- SshInput is only used for applicative form prompting, this converts
|
2012-09-04 19:27:06 +00:00
|
|
|
|
- the result of such a form into a SshData. -}
|
2012-09-13 20:47:44 +00:00
|
|
|
|
mkSshData :: SshInput -> SshData
|
|
|
|
|
mkSshData s = SshData
|
2012-12-06 21:09:08 +00:00
|
|
|
|
{ sshHostName = fromMaybe "" $ inputHostname s
|
|
|
|
|
, sshUserName = inputUsername s
|
|
|
|
|
, sshDirectory = fromMaybe "" $ inputDirectory s
|
2012-09-10 21:53:51 +00:00
|
|
|
|
, sshRepoName = genSshRepoName
|
2012-12-06 21:09:08 +00:00
|
|
|
|
(T.unpack $ fromJust $ inputHostname s)
|
|
|
|
|
(maybe "" T.unpack $ inputDirectory s)
|
|
|
|
|
, sshPort = inputPort s
|
2012-09-04 19:27:06 +00:00
|
|
|
|
, needsPubKey = False
|
2013-09-29 18:39:10 +00:00
|
|
|
|
, sshCapabilities = [] -- untested
|
2012-09-04 19:27:06 +00:00
|
|
|
|
}
|
|
|
|
|
|
2013-03-16 16:58:59 +00:00
|
|
|
|
mkSshInput :: SshData -> SshInput
|
|
|
|
|
mkSshInput s = SshInput
|
|
|
|
|
{ inputHostname = Just $ sshHostName s
|
|
|
|
|
, inputUsername = sshUserName s
|
|
|
|
|
, inputDirectory = Just $ sshDirectory s
|
|
|
|
|
, inputPort = sshPort s
|
|
|
|
|
}
|
|
|
|
|
|
2013-06-03 20:33:05 +00:00
|
|
|
|
#if MIN_VERSION_yesod(1,2,0)
|
2013-06-02 19:57:22 +00:00
|
|
|
|
sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
|
2013-06-03 20:33:05 +00:00
|
|
|
|
#else
|
|
|
|
|
sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
|
|
|
|
|
#endif
|
2012-12-03 02:33:30 +00:00
|
|
|
|
sshInputAForm hostnamefield def = SshInput
|
2014-04-18 00:07:09 +00:00
|
|
|
|
<$> aopt check_hostname (bfs "Host name") (Just $ inputHostname def)
|
|
|
|
|
<*> aopt check_username (bfs "User name") (Just $ inputUsername def)
|
|
|
|
|
<*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
|
|
|
|
|
<*> areq intField (bfs "Port") (Just $ inputPort def)
|
2012-10-31 06:34:03 +00:00
|
|
|
|
where
|
2013-05-04 20:36:51 +00:00
|
|
|
|
check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
|
|
|
|
|
bad_username textField
|
|
|
|
|
|
2013-05-06 20:45:49 +00:00
|
|
|
|
bad_username = "bad user name" :: Text
|
2013-05-04 20:04:17 +00:00
|
|
|
|
#ifndef __ANDROID__
|
2013-05-04 20:36:51 +00:00
|
|
|
|
bad_hostname = "cannot resolve host name" :: Text
|
|
|
|
|
|
2012-12-03 02:33:30 +00:00
|
|
|
|
check_hostname = checkM (liftIO . checkdns) hostnamefield
|
2012-10-31 06:34:03 +00:00
|
|
|
|
checkdns t = do
|
|
|
|
|
let h = T.unpack t
|
2013-05-04 18:25:30 +00:00
|
|
|
|
let canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] }
|
2012-10-31 06:34:03 +00:00
|
|
|
|
r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing
|
2013-10-02 04:33:40 +00:00
|
|
|
|
return $ case mapMaybe addrCanonName <$> r of
|
2012-10-31 06:34:03 +00:00
|
|
|
|
-- canonicalize input hostname if it had no dot
|
|
|
|
|
Just (fullname:_)
|
|
|
|
|
| '.' `elem` h -> Right t
|
|
|
|
|
| otherwise -> Right $ T.pack fullname
|
|
|
|
|
Just [] -> Right t
|
|
|
|
|
Nothing -> Left bad_hostname
|
2013-05-04 18:25:30 +00:00
|
|
|
|
#else
|
2013-05-04 20:04:17 +00:00
|
|
|
|
-- getAddrInfo currently broken on Android
|
|
|
|
|
check_hostname = hostnamefield -- unchecked
|
2013-05-04 18:25:30 +00:00
|
|
|
|
#endif
|
2012-08-31 22:59:57 +00:00
|
|
|
|
|
|
|
|
|
data ServerStatus
|
|
|
|
|
= UntestedServer
|
|
|
|
|
| UnusableServer Text -- reason why it's not usable
|
2013-09-29 18:39:10 +00:00
|
|
|
|
| UsableServer [SshServerCapability]
|
2012-09-02 04:27:48 +00:00
|
|
|
|
deriving (Eq)
|
2012-08-31 22:59:57 +00:00
|
|
|
|
|
2013-09-29 18:39:10 +00:00
|
|
|
|
capabilities :: ServerStatus -> [SshServerCapability]
|
|
|
|
|
capabilities (UsableServer cs) = cs
|
|
|
|
|
capabilities _ = []
|
2012-08-31 22:59:57 +00:00
|
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
|
getAddSshR :: Handler Html
|
2013-03-16 22:48:23 +00:00
|
|
|
|
getAddSshR = postAddSshR
|
2013-06-27 05:15:28 +00:00
|
|
|
|
postAddSshR :: Handler Html
|
2013-03-16 22:48:23 +00:00
|
|
|
|
postAddSshR = sshConfigurator $ do
|
2013-10-02 19:54:32 +00:00
|
|
|
|
username <- liftIO $ T.pack <$> myUserName
|
2013-06-03 17:51:54 +00:00
|
|
|
|
((result, form), enctype) <- liftH $
|
2014-04-18 00:07:09 +00:00
|
|
|
|
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField $
|
2013-10-02 19:54:32 +00:00
|
|
|
|
SshInput Nothing (Just username) Nothing 22
|
2012-08-31 22:59:57 +00:00
|
|
|
|
case result of
|
2012-09-13 20:47:44 +00:00
|
|
|
|
FormSuccess sshinput -> do
|
2014-05-01 01:27:17 +00:00
|
|
|
|
s <- liftIO $ testServer NoPassword sshinput
|
2012-09-13 20:47:44 +00:00
|
|
|
|
case s of
|
2014-05-01 01:27:17 +00:00
|
|
|
|
-- XXX FIXME: now what???
|
2012-09-13 20:47:44 +00:00
|
|
|
|
Left status -> showform form enctype status
|
2013-10-02 19:54:32 +00:00
|
|
|
|
Right (sshdata, u) -> liftH $ redirect $ ConfirmSshR sshdata u
|
2012-08-31 22:59:57 +00:00
|
|
|
|
_ -> showform form enctype UntestedServer
|
2012-10-31 06:34:03 +00:00
|
|
|
|
where
|
2012-11-25 04:38:11 +00:00
|
|
|
|
showform form enctype status = $(widgetFile "configurators/ssh/add")
|
2012-08-31 22:59:57 +00:00
|
|
|
|
|
2013-03-16 16:58:59 +00:00
|
|
|
|
sshTestModal :: Widget
|
|
|
|
|
sshTestModal = $(widgetFile "configurators/ssh/testmodal")
|
|
|
|
|
|
2013-10-02 19:54:32 +00:00
|
|
|
|
sshSetupModal :: SshData -> Widget
|
|
|
|
|
sshSetupModal sshdata = $(widgetFile "configurators/ssh/setupmodal")
|
|
|
|
|
|
2013-09-27 03:28:25 +00:00
|
|
|
|
getEnableRsyncR :: UUID -> Handler Html
|
|
|
|
|
getEnableRsyncR = postEnableRsyncR
|
|
|
|
|
postEnableRsyncR :: UUID -> Handler Html
|
2013-10-01 20:08:01 +00:00
|
|
|
|
postEnableRsyncR = enableSpecialSshRemote getsshinput enableRsyncNet enablersync
|
2013-09-27 03:28:25 +00:00
|
|
|
|
where
|
2013-10-02 19:54:32 +00:00
|
|
|
|
enablersync sshdata u = redirect $ ConfirmSshR
|
|
|
|
|
(sshdata { sshCapabilities = [RsyncCapable] }) u
|
2013-10-01 20:08:01 +00:00
|
|
|
|
getsshinput = parseSshUrl <=< M.lookup "rsyncurl"
|
2013-09-27 03:28:25 +00:00
|
|
|
|
|
2013-09-26 21:26:13 +00:00
|
|
|
|
{- This only handles gcrypt repositories that are located on ssh servers;
|
|
|
|
|
- ones on local drives are handled via another part of the UI. -}
|
2013-10-02 19:54:32 +00:00
|
|
|
|
getEnableSshGCryptR :: UUID -> Handler Html
|
|
|
|
|
getEnableSshGCryptR = postEnableSshGCryptR
|
|
|
|
|
postEnableSshGCryptR :: UUID -> Handler Html
|
|
|
|
|
postEnableSshGCryptR u = whenGcryptInstalled $
|
2013-10-01 20:08:01 +00:00
|
|
|
|
enableSpecialSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u
|
2013-09-27 03:28:25 +00:00
|
|
|
|
where
|
2014-04-20 22:38:59 +00:00
|
|
|
|
enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
|
2013-10-01 17:43:35 +00:00
|
|
|
|
sshConfigurator $
|
|
|
|
|
checkExistingGCrypt sshdata' $
|
|
|
|
|
error "Expected to find an encrypted git repository, but did not."
|
2013-10-01 20:08:01 +00:00
|
|
|
|
getsshinput = parseSshUrl <=< M.lookup "gitrepo"
|
2013-09-26 21:26:13 +00:00
|
|
|
|
|
2013-10-01 20:08:01 +00:00
|
|
|
|
{- To enable a special remote that uses ssh as its transport,
|
2013-09-27 03:28:25 +00:00
|
|
|
|
- parse a config key to get its url, and display a form whose
|
|
|
|
|
- only real purpose is to check if ssh public keys need to be
|
|
|
|
|
- set up.
|
2012-09-13 20:47:44 +00:00
|
|
|
|
-}
|
2013-10-02 19:54:32 +00:00
|
|
|
|
enableSpecialSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html
|
2013-10-01 20:08:01 +00:00
|
|
|
|
enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
|
2013-03-04 20:36:38 +00:00
|
|
|
|
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
|
2013-10-01 20:08:01 +00:00
|
|
|
|
case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of
|
2012-10-31 20:14:52 +00:00
|
|
|
|
(Just sshinput, Just reponame) -> sshConfigurator $ do
|
2013-06-03 17:51:54 +00:00
|
|
|
|
((result, form), enctype) <- liftH $
|
2014-04-18 00:07:09 +00:00
|
|
|
|
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField sshinput
|
2012-09-13 20:47:44 +00:00
|
|
|
|
case result of
|
|
|
|
|
FormSuccess sshinput'
|
2012-12-06 21:09:08 +00:00
|
|
|
|
| isRsyncNet (inputHostname sshinput') ->
|
2013-09-27 03:28:25 +00:00
|
|
|
|
void $ liftH $ rsyncnetsetup sshinput' reponame
|
2012-09-13 20:47:44 +00:00
|
|
|
|
| otherwise -> do
|
|
|
|
|
s <- liftIO $ testServer sshinput'
|
|
|
|
|
case s of
|
|
|
|
|
Left status -> showform form enctype status
|
2013-10-02 19:54:32 +00:00
|
|
|
|
Right (sshdata, _u) -> void $ liftH $ genericsetup
|
|
|
|
|
( sshdata { sshRepoName = reponame } ) u
|
2012-09-13 20:47:44 +00:00
|
|
|
|
_ -> showform form enctype UntestedServer
|
2012-10-31 20:14:52 +00:00
|
|
|
|
_ -> redirect AddSshR
|
2012-10-31 06:34:03 +00:00
|
|
|
|
where
|
2013-10-01 20:08:01 +00:00
|
|
|
|
unmangle sshdata = sshdata
|
|
|
|
|
{ sshHostName = T.pack $ unMangleSshHostName $
|
|
|
|
|
T.unpack $ sshHostName sshdata
|
|
|
|
|
}
|
2012-10-31 06:34:03 +00:00
|
|
|
|
showform form enctype status = do
|
2013-04-03 21:01:40 +00:00
|
|
|
|
description <- liftAnnex $ T.pack <$> prettyUUID u
|
2012-10-31 06:34:03 +00:00
|
|
|
|
$(widgetFile "configurators/ssh/enable")
|
2012-09-13 20:47:44 +00:00
|
|
|
|
|
2014-04-20 22:38:59 +00:00
|
|
|
|
{- To deal with git-annex and possibly even git and rsync not being
|
|
|
|
|
- available in the remote server's PATH, when git-annex was installed
|
|
|
|
|
- from the standalone tarball etc, look for a ~/.ssh/git-annex-wrapper
|
|
|
|
|
- and if it's there, use it to run a command. -}
|
|
|
|
|
wrapCommand :: String -> String
|
|
|
|
|
wrapCommand cmd = "if [ -x " ++ commandWrapper ++ " ]; then " ++ commandWrapper ++ " " ++ cmd ++ "; else " ++ cmd ++ "; fi"
|
|
|
|
|
|
|
|
|
|
commandWrapper :: String
|
|
|
|
|
commandWrapper = "~/.ssh/git-annex-wrapper"
|
|
|
|
|
|
2014-05-01 01:27:17 +00:00
|
|
|
|
data UsePassword
|
|
|
|
|
= NoPassword
|
|
|
|
|
| CachedPassword
|
|
|
|
|
deriving (Eq)
|
|
|
|
|
|
2012-09-02 00:37:35 +00:00
|
|
|
|
{- Test if we can ssh into the server.
|
|
|
|
|
-
|
2014-05-01 01:27:17 +00:00
|
|
|
|
- To detect if passwordless login is already enabled on the server,
|
|
|
|
|
- pass NoPassword.
|
|
|
|
|
-
|
|
|
|
|
- If that fails, the caller should prompt the user for the necessary
|
|
|
|
|
- password, and retry with CachedPassword.
|
2012-09-02 00:37:35 +00:00
|
|
|
|
-
|
2013-09-29 18:39:10 +00:00
|
|
|
|
- Once logged into the server, probe to see if git-annex-shell,
|
|
|
|
|
- git, and rsync are available.
|
2014-04-20 22:38:59 +00:00
|
|
|
|
-
|
2013-09-29 18:39:10 +00:00
|
|
|
|
- Note that, ~/.ssh/git-annex-shell may be
|
2012-09-26 22:59:18 +00:00
|
|
|
|
- present, while git-annex-shell is not in PATH.
|
2014-04-20 22:38:59 +00:00
|
|
|
|
- Also, git and rsync may not be in PATH; as long as the commandWrapper
|
|
|
|
|
- is present, assume it is able to be used to run them.
|
2013-10-02 19:54:32 +00:00
|
|
|
|
-
|
|
|
|
|
- Also probe to see if there is already a git repository at the location
|
|
|
|
|
- with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.)
|
2012-09-02 00:37:35 +00:00
|
|
|
|
-}
|
2014-05-01 01:27:17 +00:00
|
|
|
|
testServer :: UsePassword -> SshInput -> IO (Either ServerStatus (SshData, UUID))
|
|
|
|
|
testServer _ (SshInput { inputHostname = Nothing }) = return $
|
2012-09-13 20:47:44 +00:00
|
|
|
|
Left $ UnusableServer "Please enter a host name."
|
2014-05-01 01:27:17 +00:00
|
|
|
|
testServer usepassword sshinput@(SshInput { inputHostname = Just hn }) = do
|
|
|
|
|
(status, u) <- probe $
|
|
|
|
|
if usepassword == NoPassword
|
|
|
|
|
then [sshOpt "NumberOfPasswordPrompts" "0"]
|
|
|
|
|
else []
|
2013-09-29 18:39:10 +00:00
|
|
|
|
case capabilities status of
|
2014-05-01 01:27:17 +00:00
|
|
|
|
[] -> return $ Left status'
|
|
|
|
|
cs -> ret cs (usepassword == CachedPassword) u
|
2012-10-31 06:34:03 +00:00
|
|
|
|
where
|
2013-10-02 19:54:32 +00:00
|
|
|
|
ret cs needspubkey u = do
|
|
|
|
|
let sshdata = (mkSshData sshinput)
|
|
|
|
|
{ needsPubKey = needspubkey
|
|
|
|
|
, sshCapabilities = cs
|
|
|
|
|
}
|
|
|
|
|
return $ Right (sshdata, u)
|
2012-10-31 06:34:03 +00:00
|
|
|
|
probe extraopts = do
|
2013-04-23 00:24:53 +00:00
|
|
|
|
let remotecommand = shellWrap $ intercalate ";"
|
2012-10-31 06:34:03 +00:00
|
|
|
|
[ report "loggedin"
|
|
|
|
|
, checkcommand "git-annex-shell"
|
2013-09-29 18:39:10 +00:00
|
|
|
|
, checkcommand "git"
|
2012-10-31 06:34:03 +00:00
|
|
|
|
, checkcommand "rsync"
|
|
|
|
|
, checkcommand shim
|
2014-04-20 22:38:59 +00:00
|
|
|
|
, checkcommand commandWrapper
|
2013-10-02 19:54:32 +00:00
|
|
|
|
, getgitconfig (T.unpack <$> inputDirectory sshinput)
|
2012-10-31 06:34:03 +00:00
|
|
|
|
]
|
|
|
|
|
knownhost <- knownHost hn
|
|
|
|
|
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"
|
|
|
|
|
, "-n" -- don't read from stdin
|
2012-12-06 21:09:08 +00:00
|
|
|
|
, "-p", show (inputPort sshinput)
|
|
|
|
|
, genSshHost
|
|
|
|
|
(fromJust $ inputHostname sshinput)
|
|
|
|
|
(inputUsername sshinput)
|
2012-10-31 06:34:03 +00:00
|
|
|
|
, remotecommand
|
|
|
|
|
]
|
2013-02-26 17:04:37 +00:00
|
|
|
|
parsetranscript . fst <$> sshTranscript sshopts Nothing
|
2013-09-29 18:39:10 +00:00
|
|
|
|
parsetranscript s =
|
|
|
|
|
let cs = map snd $ filter (reported . fst)
|
|
|
|
|
[ ("git-annex-shell", GitAnnexShellCapable)
|
|
|
|
|
, (shim, GitAnnexShellCapable)
|
|
|
|
|
, ("git", GitCapable)
|
|
|
|
|
, ("rsync", RsyncCapable)
|
2014-04-20 22:38:59 +00:00
|
|
|
|
, (commandWrapper, GitCapable)
|
|
|
|
|
, (commandWrapper, RsyncCapable)
|
2013-09-29 18:39:10 +00:00
|
|
|
|
]
|
2013-10-02 19:54:32 +00:00
|
|
|
|
u = fromMaybe NoUUID $ headMaybe $ mapMaybe finduuid $
|
|
|
|
|
map (separate (== '=')) $ lines s
|
2013-09-29 18:39:10 +00:00
|
|
|
|
in if null cs
|
2013-10-02 19:54:32 +00:00
|
|
|
|
then (UnusableServer unusablereason, u)
|
|
|
|
|
else (UsableServer cs, u)
|
2012-10-31 06:34:03 +00:00
|
|
|
|
where
|
|
|
|
|
reported r = token r `isInfixOf` s
|
2013-10-02 19:54:32 +00:00
|
|
|
|
unusablereason = if reported "loggedin"
|
|
|
|
|
then "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
|
|
|
|
|
else T.pack $ "Failed to ssh to the server. Transcript: " ++ s
|
|
|
|
|
finduuid (k, v)
|
|
|
|
|
| k == "annex.uuid" = Just $ toUUID v
|
|
|
|
|
| k == GCrypt.coreGCryptId = Just $ genUUIDInNameSpace gCryptNameSpace v
|
|
|
|
|
| otherwise = Nothing
|
2013-03-29 17:09:30 +00:00
|
|
|
|
|
2012-10-31 06:34:03 +00:00
|
|
|
|
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
|
|
|
|
|
token r = "git-annex-probe " ++ r
|
2014-04-20 22:38:59 +00:00
|
|
|
|
report r = "echo " ++ shellEscape (token r)
|
2012-10-31 06:34:03 +00:00
|
|
|
|
shim = "~/.ssh/git-annex-shell"
|
2013-10-02 19:54:32 +00:00
|
|
|
|
getgitconfig (Just d)
|
|
|
|
|
| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"
|
|
|
|
|
getgitconfig _ = "echo"
|
2012-09-04 19:27:06 +00:00
|
|
|
|
|
|
|
|
|
{- Runs a ssh command; if it fails shows the user the transcript,
|
|
|
|
|
- and if it succeeds, runs an action. -}
|
2014-01-01 19:49:51 +00:00
|
|
|
|
sshSetup :: [String] -> Maybe String -> Handler Html -> Handler Html
|
2012-09-04 19:27:06 +00:00
|
|
|
|
sshSetup opts input a = do
|
2014-01-01 19:49:51 +00:00
|
|
|
|
(transcript, ok) <- liftIO $ sshTranscript opts input
|
2012-09-04 19:27:06 +00:00
|
|
|
|
if ok
|
|
|
|
|
then a
|
|
|
|
|
else showSshErr transcript
|
|
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
|
showSshErr :: String -> Handler Html
|
2012-09-04 19:27:06 +00:00
|
|
|
|
showSshErr msg = sshConfigurator $
|
2012-09-09 03:32:08 +00:00
|
|
|
|
$(widgetFile "configurators/ssh/error")
|
2012-09-04 19:27:06 +00:00
|
|
|
|
|
2014-04-20 22:38:59 +00:00
|
|
|
|
{- The UUID will be NoUUID when the repository does not already exist,
|
|
|
|
|
- or was not a git-annex repository before. -}
|
2013-10-02 19:54:32 +00:00
|
|
|
|
getConfirmSshR :: SshData -> UUID -> Handler Html
|
|
|
|
|
getConfirmSshR sshdata u
|
|
|
|
|
| u == NoUUID = handlenew
|
|
|
|
|
| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidMap)
|
|
|
|
|
where
|
|
|
|
|
handlenew = sshConfigurator $ do
|
|
|
|
|
secretkeys <- sortBy (comparing snd) . M.toList
|
|
|
|
|
<$> liftIO secretKeys
|
|
|
|
|
$(widgetFile "configurators/ssh/confirm")
|
|
|
|
|
handleexisting Nothing = sshConfigurator $
|
|
|
|
|
-- Not a UUID we know, so prompt about combining.
|
|
|
|
|
$(widgetFile "configurators/ssh/combine")
|
|
|
|
|
handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do
|
|
|
|
|
m <- liftAnnex readRemoteLog
|
|
|
|
|
case M.lookup "type" =<< M.lookup u m of
|
|
|
|
|
Just "gcrypt" -> combineExistingGCrypt sshdata' u
|
|
|
|
|
-- This handles enabling git repositories
|
|
|
|
|
-- that already exist.
|
|
|
|
|
_ -> makeSshRepo sshdata'
|
|
|
|
|
|
|
|
|
|
{- The user has confirmed they want to combine with a ssh repository,
|
|
|
|
|
- which is not known to us. So it might be using gcrypt. -}
|
|
|
|
|
getCombineSshR :: SshData -> Handler Html
|
|
|
|
|
getCombineSshR sshdata = prepSsh False sshdata $ \sshdata' ->
|
|
|
|
|
sshConfigurator $
|
|
|
|
|
checkExistingGCrypt sshdata' $
|
|
|
|
|
void $ liftH $ makeSshRepo sshdata'
|
2012-09-02 04:27:48 +00:00
|
|
|
|
|
2013-03-16 16:58:59 +00:00
|
|
|
|
getRetrySshR :: SshData -> Handler ()
|
|
|
|
|
getRetrySshR sshdata = do
|
|
|
|
|
s <- liftIO $ testServer $ mkSshInput sshdata
|
2013-10-02 19:54:32 +00:00
|
|
|
|
redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s
|
2013-03-16 16:58:59 +00:00
|
|
|
|
|
2014-04-20 22:38:59 +00:00
|
|
|
|
{- Making a new git repository. -}
|
2013-06-27 05:15:28 +00:00
|
|
|
|
getMakeSshGitR :: SshData -> Handler Html
|
2014-04-20 22:38:59 +00:00
|
|
|
|
getMakeSshGitR sshdata = prepSsh True sshdata makeSshRepo
|
2012-09-02 21:32:24 +00:00
|
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
|
getMakeSshRsyncR :: SshData -> Handler Html
|
2013-10-01 17:43:35 +00:00
|
|
|
|
getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) makeSshRepo
|
|
|
|
|
|
|
|
|
|
rsyncOnly :: SshData -> SshData
|
|
|
|
|
rsyncOnly sshdata = sshdata { sshCapabilities = [RsyncCapable] }
|
2012-09-02 21:32:24 +00:00
|
|
|
|
|
2013-09-29 18:39:10 +00:00
|
|
|
|
getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
|
2013-10-01 17:43:35 +00:00
|
|
|
|
getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
|
|
|
|
|
withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
|
|
|
|
|
getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
|
2014-04-20 22:38:59 +00:00
|
|
|
|
prepSsh False sshdata $ makeGCryptRepo keyid
|
2013-10-01 17:43:35 +00:00
|
|
|
|
|
|
|
|
|
{- Detect if the user entered a location with an existing, known
|
|
|
|
|
- gcrypt repository, and enable it. Otherwise, runs the action. -}
|
|
|
|
|
checkExistingGCrypt :: SshData -> Widget -> Widget
|
2013-10-22 17:32:10 +00:00
|
|
|
|
checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $ do
|
|
|
|
|
mu <- liftAnnex $ probeGCryptRemoteUUID repourl
|
|
|
|
|
case mu of
|
|
|
|
|
Just u -> void $ liftH $
|
|
|
|
|
combineExistingGCrypt sshdata u
|
|
|
|
|
Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
|
2013-10-01 17:43:35 +00:00
|
|
|
|
where
|
2013-10-01 20:08:01 +00:00
|
|
|
|
repourl = genSshUrl sshdata
|
2013-10-01 17:43:35 +00:00
|
|
|
|
|
|
|
|
|
{- Enables an existing gcrypt special remote. -}
|
|
|
|
|
enableGCrypt :: SshData -> RemoteName -> Handler Html
|
|
|
|
|
enableGCrypt sshdata reponame =
|
|
|
|
|
setupCloudRemote TransferGroup Nothing $
|
2014-02-11 18:06:50 +00:00
|
|
|
|
enableSpecialRemote reponame GCrypt.remote Nothing $ M.fromList
|
2013-10-01 20:08:01 +00:00
|
|
|
|
[("gitrepo", genSshUrl sshdata)]
|
2013-09-29 18:39:10 +00:00
|
|
|
|
|
2013-10-02 19:54:32 +00:00
|
|
|
|
{- Combining with a gcrypt repository that may not be
|
|
|
|
|
- known in remote.log, so probe the gcrypt repo. -}
|
|
|
|
|
combineExistingGCrypt :: SshData -> UUID -> Handler Html
|
|
|
|
|
combineExistingGCrypt sshdata u = do
|
|
|
|
|
reponame <- liftAnnex $ getGCryptRemoteName u repourl
|
|
|
|
|
enableGCrypt sshdata reponame
|
|
|
|
|
where
|
|
|
|
|
repourl = genSshUrl sshdata
|
|
|
|
|
|
2013-10-01 17:43:35 +00:00
|
|
|
|
{- Sets up remote repository for ssh, or directory for rsync. -}
|
|
|
|
|
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
|
2014-04-20 22:38:59 +00:00
|
|
|
|
prepSsh needsinit sshdata a
|
2012-09-03 00:43:32 +00:00
|
|
|
|
| needsPubKey sshdata = do
|
2012-09-13 04:57:52 +00:00
|
|
|
|
keypair <- liftIO genSshKeyPair
|
2012-09-10 18:42:46 +00:00
|
|
|
|
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
|
2014-04-20 22:38:59 +00:00
|
|
|
|
prepSsh' needsinit sshdata sshdata' (Just keypair) a
|
2012-12-06 21:09:08 +00:00
|
|
|
|
| sshPort sshdata /= 22 = do
|
|
|
|
|
sshdata' <- liftIO $ setSshConfig sshdata []
|
2014-04-20 22:38:59 +00:00
|
|
|
|
prepSsh' needsinit sshdata sshdata' Nothing a
|
|
|
|
|
| otherwise = prepSsh' needsinit sshdata sshdata Nothing a
|
2012-09-03 00:43:32 +00:00
|
|
|
|
|
2013-10-01 17:43:35 +00:00
|
|
|
|
prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
|
2014-04-20 22:38:59 +00:00
|
|
|
|
prepSsh' needsinit origsshdata sshdata keypair a = sshSetup
|
2013-10-01 20:16:38 +00:00
|
|
|
|
[ "-p", show (sshPort origsshdata)
|
|
|
|
|
, genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
|
|
|
|
|
, remoteCommand
|
2014-01-01 19:49:51 +00:00
|
|
|
|
] Nothing (a sshdata)
|
2012-10-31 06:34:03 +00:00
|
|
|
|
where
|
|
|
|
|
remotedir = T.unpack $ sshDirectory sshdata
|
2013-04-23 00:24:53 +00:00
|
|
|
|
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
|
2012-10-31 06:34:03 +00:00
|
|
|
|
[ Just $ "mkdir -p " ++ shellEscape remotedir
|
|
|
|
|
, Just $ "cd " ++ shellEscape remotedir
|
2014-04-20 22:38:59 +00:00
|
|
|
|
, if rsynconly then Nothing else Just $ unwords
|
|
|
|
|
[ "if [ ! -d .git ]; then"
|
|
|
|
|
, wrapCommand "git init --bare --shared"
|
|
|
|
|
, "&&"
|
|
|
|
|
, wrapCommand "git config receive.denyNonFastforwards"
|
|
|
|
|
, ";fi"
|
|
|
|
|
]
|
|
|
|
|
, if needsinit then Just (wrapCommand "git annex init") else Nothing
|
2013-10-01 20:16:38 +00:00
|
|
|
|
, if needsPubKey origsshdata
|
|
|
|
|
then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
|
2012-10-31 06:34:03 +00:00
|
|
|
|
else Nothing
|
|
|
|
|
]
|
2013-10-01 20:16:38 +00:00
|
|
|
|
rsynconly = onlyCapability origsshdata RsyncCapable
|
2013-10-01 17:43:35 +00:00
|
|
|
|
|
|
|
|
|
makeSshRepo :: SshData -> Handler Html
|
2014-04-20 19:10:29 +00:00
|
|
|
|
makeSshRepo sshdata
|
|
|
|
|
| onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing go
|
2014-04-20 19:30:39 +00:00
|
|
|
|
| otherwise = makeSshRepoConnection go
|
2014-04-20 19:10:29 +00:00
|
|
|
|
where
|
|
|
|
|
go = makeSshRemote sshdata
|
2012-09-04 19:27:06 +00:00
|
|
|
|
|
2014-04-20 19:30:39 +00:00
|
|
|
|
makeSshRepoConnection :: Annex RemoteName -> Handler Html
|
|
|
|
|
makeSshRepoConnection a = setupRemote postsetup TransferGroup Nothing a
|
|
|
|
|
where
|
|
|
|
|
postsetup u = do
|
|
|
|
|
liftAssistant $ sendRemoteControl RELOAD
|
|
|
|
|
redirect $ EditNewRepositoryR u
|
|
|
|
|
|
2013-10-01 17:43:35 +00:00
|
|
|
|
makeGCryptRepo :: KeyId -> SshData -> Handler Html
|
2014-04-20 19:30:39 +00:00
|
|
|
|
makeGCryptRepo keyid sshdata = makeSshRepoConnection $
|
2013-10-01 20:08:01 +00:00
|
|
|
|
makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
|
2012-09-02 21:32:24 +00:00
|
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
|
getAddRsyncNetR :: Handler Html
|
2013-03-16 22:48:23 +00:00
|
|
|
|
getAddRsyncNetR = postAddRsyncNetR
|
2013-06-27 05:15:28 +00:00
|
|
|
|
postAddRsyncNetR :: Handler Html
|
2013-03-16 22:48:23 +00:00
|
|
|
|
postAddRsyncNetR = do
|
2013-10-14 16:19:11 +00:00
|
|
|
|
((result, form), enctype) <- runFormPostNoToken $
|
2014-04-18 00:07:09 +00:00
|
|
|
|
renderBootstrap3 bootstrapFormLayout $ sshInputAForm hostnamefield $
|
2012-12-06 21:09:08 +00:00
|
|
|
|
SshInput Nothing Nothing Nothing 22
|
2013-09-26 20:09:45 +00:00
|
|
|
|
let showform status = inpage $
|
|
|
|
|
$(widgetFile "configurators/rsync.net/add")
|
2012-09-03 04:39:55 +00:00
|
|
|
|
case result of
|
2012-09-13 20:47:44 +00:00
|
|
|
|
FormSuccess sshinput
|
2013-09-27 20:21:56 +00:00
|
|
|
|
| isRsyncNet (inputHostname sshinput) ->
|
|
|
|
|
go sshinput
|
2012-09-13 20:47:44 +00:00
|
|
|
|
| otherwise ->
|
|
|
|
|
showform $ UnusableServer
|
|
|
|
|
"That is not a rsync.net host name."
|
2012-09-03 04:39:55 +00:00
|
|
|
|
_ -> showform UntestedServer
|
2012-12-03 02:33:30 +00:00
|
|
|
|
where
|
2013-09-26 20:09:45 +00:00
|
|
|
|
inpage = page "Add a Rsync.net repository" (Just Configuration)
|
2013-04-26 03:44:55 +00:00
|
|
|
|
hostnamefield = textField `withExpandableNote` ("Help", help)
|
2012-12-03 02:33:30 +00:00
|
|
|
|
help = [whamlet|
|
2013-04-26 03:44:55 +00:00
|
|
|
|
<div>
|
|
|
|
|
When you sign up for a Rsync.net account, you should receive an #
|
|
|
|
|
email from them with the host name and user name to put here.
|
|
|
|
|
<div>
|
|
|
|
|
The host name will be something like "usw-s001.rsync.net", and the #
|
|
|
|
|
user name something like "7491"
|
2012-12-03 02:33:30 +00:00
|
|
|
|
|]
|
2013-09-27 20:21:56 +00:00
|
|
|
|
go sshinput = do
|
2013-09-26 20:09:45 +00:00
|
|
|
|
let reponame = genSshRepoName "rsync.net"
|
|
|
|
|
(maybe "" T.unpack $ inputDirectory sshinput)
|
2013-09-27 20:21:56 +00:00
|
|
|
|
prepRsyncNet sshinput reponame $ \sshdata -> inpage $
|
2013-10-01 17:43:35 +00:00
|
|
|
|
checkExistingGCrypt sshdata $ do
|
2013-09-27 20:21:56 +00:00
|
|
|
|
secretkeys <- sortBy (comparing snd) . M.toList
|
|
|
|
|
<$> liftIO secretKeys
|
|
|
|
|
$(widgetFile "configurators/rsync.net/encrypt")
|
2012-09-13 20:47:44 +00:00
|
|
|
|
|
2013-09-26 20:09:45 +00:00
|
|
|
|
getMakeRsyncNetSharedR :: SshData -> Handler Html
|
2013-10-01 17:43:35 +00:00
|
|
|
|
getMakeRsyncNetSharedR = makeSshRepo . rsyncOnly
|
2013-09-26 20:09:45 +00:00
|
|
|
|
|
|
|
|
|
{- Make a gcrypt special remote on rsync.net. -}
|
|
|
|
|
getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
|
2013-09-26 22:42:54 +00:00
|
|
|
|
getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
|
|
|
|
|
withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
|
2013-10-02 04:33:40 +00:00
|
|
|
|
getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
|
2014-01-01 19:49:51 +00:00
|
|
|
|
sshSetup [sshhost, gitinit] Nothing $ makeGCryptRepo keyid sshdata
|
2013-09-26 20:09:45 +00:00
|
|
|
|
where
|
|
|
|
|
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
|
|
|
|
gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
|
|
|
|
|
|
2013-09-27 03:28:25 +00:00
|
|
|
|
enableRsyncNet :: SshInput -> String -> Handler Html
|
|
|
|
|
enableRsyncNet sshinput reponame =
|
2013-10-01 17:43:35 +00:00
|
|
|
|
prepRsyncNet sshinput reponame $ makeSshRepo . rsyncOnly
|
2013-09-27 03:28:25 +00:00
|
|
|
|
|
2013-09-27 20:21:56 +00:00
|
|
|
|
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
|
2013-09-27 03:28:25 +00:00
|
|
|
|
enableRsyncNetGCrypt sshinput reponame =
|
2013-10-22 17:32:10 +00:00
|
|
|
|
prepRsyncNet sshinput reponame $ \sshdata -> whenGcryptInstalled $
|
|
|
|
|
checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted notinstalled $
|
2013-10-01 17:43:35 +00:00
|
|
|
|
enableGCrypt sshdata reponame
|
2013-09-27 05:03:50 +00:00
|
|
|
|
where
|
2013-09-27 20:21:56 +00:00
|
|
|
|
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
|
2013-10-22 17:32:10 +00:00
|
|
|
|
notinstalled = error "internal"
|
2013-09-26 20:09:45 +00:00
|
|
|
|
|
2014-02-14 19:42:35 +00:00
|
|
|
|
{- Prepares rsync.net ssh key and creates the directory that will be
|
|
|
|
|
- used on rsync.net. If successful, runs an action with its SshData.
|
|
|
|
|
-
|
|
|
|
|
- To append the ssh key to rsync.net's authorized_keys, their
|
|
|
|
|
- documentation recommends a dd methodd, where the line is fed
|
|
|
|
|
- in to ssh over stdin.
|
|
|
|
|
-
|
|
|
|
|
- On Windows, ssh password prompting happens on stdin, so cannot
|
|
|
|
|
- feed the key in that way. Instead, first rsync down any current
|
|
|
|
|
- authorized_keys file, then modifiy it, and then rsync it back up.
|
|
|
|
|
- This means 2 password prompts rather than one for Windows.
|
|
|
|
|
-}
|
2013-09-26 20:09:45 +00:00
|
|
|
|
prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
|
|
|
|
|
prepRsyncNet sshinput reponame a = do
|
2012-12-06 21:09:08 +00:00
|
|
|
|
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
|
2013-10-02 05:06:59 +00:00
|
|
|
|
keypair <- liftIO genSshKeyPair
|
2012-09-13 20:47:44 +00:00
|
|
|
|
sshdata <- liftIO $ setupSshKeyPair keypair $
|
|
|
|
|
(mkSshData sshinput)
|
2012-10-31 20:14:52 +00:00
|
|
|
|
{ sshRepoName = reponame
|
2012-09-13 20:47:44 +00:00
|
|
|
|
, needsPubKey = True
|
2013-09-29 18:39:10 +00:00
|
|
|
|
, sshCapabilities = [RsyncCapable]
|
2012-09-13 20:47:44 +00:00
|
|
|
|
}
|
2014-02-14 19:42:35 +00:00
|
|
|
|
let sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
|
|
|
|
let torsyncnet cmd = filter (not . null)
|
|
|
|
|
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
|
|
|
|
, sshhost
|
|
|
|
|
, cmd
|
|
|
|
|
]
|
|
|
|
|
#ifndef mingw32_HOST_OS
|
2012-09-13 20:47:44 +00:00
|
|
|
|
{- I'd prefer to separate commands with && , but
|
2014-02-14 19:42:35 +00:00
|
|
|
|
- rsync.net's shell does not support that. -}
|
2013-04-23 00:24:53 +00:00
|
|
|
|
let remotecommand = intercalate ";"
|
2012-09-13 20:47:44 +00:00
|
|
|
|
[ "mkdir -p .ssh"
|
|
|
|
|
, "touch .ssh/authorized_keys"
|
|
|
|
|
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
|
|
|
|
|
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
|
|
|
|
|
]
|
2014-02-14 19:42:35 +00:00
|
|
|
|
sshSetup (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata)
|
|
|
|
|
#else
|
|
|
|
|
liftIO $ withTmpDir "rsyncnet" $ \tmpdir -> do
|
|
|
|
|
createDirectory $ tmpdir </> ".ssh"
|
|
|
|
|
(oldkeys, _) <- sshTranscript (torsyncnet "cat .ssh/authorized_keys") Nothing
|
|
|
|
|
writeFile (tmpdir </> ".ssh" </> "authorized_keys")
|
|
|
|
|
(sshPubKey keypair ++ "\n" ++ oldkeys)
|
|
|
|
|
liftIO $ putStrLn "May need to prompt for your rsync.net password one more time..."
|
|
|
|
|
void $ rsync
|
|
|
|
|
[ Param "-r"
|
|
|
|
|
, File $ tmpdir </> ".ssh/"
|
|
|
|
|
, Param $ sshhost ++ ":.ssh/"
|
|
|
|
|
]
|
|
|
|
|
let remotecommand = "mkdir -p " ++ T.unpack (sshDirectory sshdata)
|
|
|
|
|
sshSetup (torsyncnet remotecommand) Nothing (a sshdata)
|
|
|
|
|
#endif
|
2012-09-13 20:47:44 +00:00
|
|
|
|
|
|
|
|
|
isRsyncNet :: Maybe Text -> Bool
|
|
|
|
|
isRsyncNet Nothing = False
|
|
|
|
|
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
|