git-annex/Assistant/WebApp/Configurators/Ssh.hs

568 lines
21 KiB
Haskell
Raw Normal View History

2012-08-31 19:17:12 +00:00
{- git-annex assistant webapp configurator for ssh-based remotes
-
- Copyright 2012-2013 Joey Hess <joey@kitenet.net>
2012-08-31 19:17:12 +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 #-}
{-# 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
import Assistant.WebApp.Gpg
import Assistant.Ssh
2013-10-28 15:33:14 +00:00
import Assistant.WebApp.MakeRemote
import Logs.Remote
import Remote
import Types.StandardGroups
import Utility.UserInfo
import Utility.Gpg
2013-10-01 20:08:01 +00:00
import Types.Remote (RemoteConfig)
import Git.Types (RemoteName)
import qualified Remote.GCrypt as GCrypt
import Annex.UUID
import Logs.UUID
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
import qualified Data.Map as M
2012-09-29 16:49:23 +00:00
import Network.Socket
import Data.Ord
2012-08-31 19:17:12 +00:00
sshConfigurator :: Widget -> Handler Html
sshConfigurator = page "Add a remote server" (Just Configuration)
data SshInput = SshInput
{ inputHostname :: Maybe Text
, inputUsername :: Maybe Text
, inputDirectory :: Maybe Text
, inputPort :: Int
2012-08-31 22:59:57 +00:00
}
deriving (Show)
{- SshInput is only used for applicative form prompting, this converts
- the result of such a form into a SshData. -}
mkSshData :: SshInput -> SshData
mkSshData s = SshData
{ sshHostName = fromMaybe "" $ inputHostname s
, sshUserName = inputUsername s
, sshDirectory = fromMaybe "" $ inputDirectory s
, sshRepoName = genSshRepoName
(T.unpack $ fromJust $ inputHostname s)
(maybe "" T.unpack $ inputDirectory s)
, sshPort = inputPort s
, needsPubKey = False
, sshCapabilities = [] -- untested
}
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
sshInputAForm hostnamefield def = SshInput
<$> aopt check_hostname "Host name" (Just $ inputHostname def)
<*> aopt check_username "User name" (Just $ inputUsername def)
<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
<*> areq intField "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
#ifndef __ANDROID__
2013-05-04 20:36:51 +00:00
bad_hostname = "cannot resolve host name" :: Text
check_hostname = checkM (liftIO . checkdns) hostnamefield
2012-10-31 06:34:03 +00:00
checkdns t = do
let h = T.unpack t
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
#else
-- getAddrInfo currently broken on Android
check_hostname = hostnamefield -- unchecked
#endif
2012-08-31 22:59:57 +00:00
data ServerStatus
= UntestedServer
| UnusableServer Text -- reason why it's not usable
| UsableServer [SshServerCapability]
deriving (Eq)
2012-08-31 22:59:57 +00:00
capabilities :: ServerStatus -> [SshServerCapability]
capabilities (UsableServer cs) = cs
capabilities _ = []
2012-08-31 22:59:57 +00:00
getAddSshR :: Handler Html
2013-03-16 22:48:23 +00:00
getAddSshR = postAddSshR
postAddSshR :: Handler Html
2013-03-16 22:48:23 +00:00
postAddSshR = sshConfigurator $ do
username <- liftIO $ T.pack <$> myUserName
((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap $ sshInputAForm textField $
SshInput Nothing (Just username) Nothing 22
2012-08-31 22:59:57 +00:00
case result of
FormSuccess sshinput -> do
s <- liftIO $ testServer sshinput
case s of
Left status -> showform form enctype status
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
sshTestModal :: Widget
sshTestModal = $(widgetFile "configurators/ssh/testmodal")
sshSetupModal :: SshData -> Widget
sshSetupModal sshdata = $(widgetFile "configurators/ssh/setupmodal")
getEnableRsyncR :: UUID -> Handler Html
getEnableRsyncR = postEnableRsyncR
postEnableRsyncR :: UUID -> Handler Html
2013-10-01 20:08:01 +00:00
postEnableRsyncR = enableSpecialSshRemote getsshinput enableRsyncNet enablersync
where
enablersync sshdata u = redirect $ ConfirmSshR
(sshdata { sshCapabilities = [RsyncCapable] }) u
2013-10-01 20:08:01 +00:00
getsshinput = parseSshUrl <=< M.lookup "rsyncurl"
{- This only handles gcrypt repositories that are located on ssh servers;
- ones on local drives are handled via another part of the UI. -}
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
where
enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
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-10-01 20:08:01 +00:00
{- To enable a special remote that uses ssh as its transport,
- 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.
-}
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
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
(Just sshinput, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap $ sshInputAForm textField sshinput
case result of
FormSuccess sshinput'
| isRsyncNet (inputHostname sshinput') ->
void $ liftH $ rsyncnetsetup sshinput' reponame
| otherwise -> do
s <- liftIO $ testServer sshinput'
case s of
Left status -> showform form enctype status
Right (sshdata, _u) -> void $ liftH $ genericsetup
( sshdata { sshRepoName = reponame } ) u
_ -> showform form enctype UntestedServer
_ -> 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
description <- liftAnnex $ T.pack <$> prettyUUID u
2012-10-31 06:34:03 +00:00
$(widgetFile "configurators/ssh/enable")
{- 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"
2012-09-02 00:37:35 +00:00
{- Test if we can ssh into the server.
-
- Two probe attempts are made. First, try sshing in using the existing
- configuration, but don't let ssh prompt for any password. If
2012-09-02 00:37:35 +00:00
- passwordless login is already enabled, use it. Otherwise,
- a special ssh key will need to be generated just for this server.
2012-09-02 00:37:35 +00:00
-
- Once logged into the server, probe to see if git-annex-shell,
- git, and rsync are available.
-
- Note that, ~/.ssh/git-annex-shell may be
- present, while git-annex-shell is not in PATH.
- 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.
-
- 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
-}
testServer :: SshInput -> IO (Either ServerStatus (SshData, UUID))
testServer (SshInput { inputHostname = Nothing }) = return $
Left $ UnusableServer "Please enter a host name."
testServer sshinput@(SshInput { inputHostname = Just hn }) = do
(status, u) <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
case capabilities status of
[] -> do
(status', u') <- probe []
case capabilities status' of
[] -> return $ Left status'
cs -> ret cs True u'
cs -> ret cs False u
2012-10-31 06:34:03 +00:00
where
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
let remotecommand = shellWrap $ intercalate ";"
2012-10-31 06:34:03 +00:00
[ report "loggedin"
, checkcommand "git-annex-shell"
, checkcommand "git"
2012-10-31 06:34:03 +00:00
, checkcommand "rsync"
, checkcommand shim
, checkcommand commandWrapper
, 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
, "-p", show (inputPort sshinput)
, genSshHost
(fromJust $ inputHostname sshinput)
(inputUsername sshinput)
2012-10-31 06:34:03 +00:00
, remotecommand
]
parsetranscript . fst <$> sshTranscript sshopts Nothing
parsetranscript s =
let cs = map snd $ filter (reported . fst)
[ ("git-annex-shell", GitAnnexShellCapable)
, (shim, GitAnnexShellCapable)
, ("git", GitCapable)
, ("rsync", RsyncCapable)
, (commandWrapper, GitCapable)
, (commandWrapper, RsyncCapable)
]
u = fromMaybe NoUUID $ headMaybe $ mapMaybe finduuid $
map (separate (== '=')) $ lines s
in if null cs
then (UnusableServer unusablereason, u)
else (UsableServer cs, u)
2012-10-31 06:34:03 +00:00
where
reported r = token r `isInfixOf` s
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
2012-10-31 06:34:03 +00:00
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
token r = "git-annex-probe " ++ r
report r = "echo " ++ shellEscape (token r)
2012-10-31 06:34:03 +00:00
shim = "~/.ssh/git-annex-shell"
getgitconfig (Just d)
| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"
getgitconfig _ = "echo"
{- Runs a ssh command; if it fails shows the user the transcript,
- and if it succeeds, runs an action. -}
sshSetup :: [String] -> Maybe String -> Handler Html -> Handler Html
sshSetup opts input a = do
(transcript, ok) <- liftIO $ sshTranscript opts input
if ok
then a
else showSshErr transcript
showSshErr :: String -> Handler Html
showSshErr msg = sshConfigurator $
2012-09-09 03:32:08 +00:00
$(widgetFile "configurators/ssh/error")
{- The UUID will be NoUUID when the repository does not already exist,
- or was not a git-annex repository before. -}
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'
getRetrySshR :: SshData -> Handler ()
getRetrySshR sshdata = do
s <- liftIO $ testServer $ mkSshInput sshdata
redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s
{- Making a new git repository. -}
getMakeSshGitR :: SshData -> Handler Html
getMakeSshGitR sshdata = prepSsh True sshdata makeSshRepo
getMakeSshRsyncR :: SshData -> Handler Html
getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) makeSshRepo
rsyncOnly :: SshData -> SshData
rsyncOnly sshdata = sshdata { sshCapabilities = [RsyncCapable] }
getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html
getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $
withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey
getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
prepSsh False sshdata $ makeGCryptRepo keyid
{- Detect if the user entered a location with an existing, known
- gcrypt repository, and enable it. Otherwise, runs the action. -}
checkExistingGCrypt :: SshData -> Widget -> Widget
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."
where
2013-10-01 20:08:01 +00:00
repourl = genSshUrl sshdata
{- Enables an existing gcrypt special remote. -}
enableGCrypt :: SshData -> RemoteName -> Handler Html
enableGCrypt sshdata reponame =
setupCloudRemote TransferGroup Nothing $
enableSpecialRemote reponame GCrypt.remote Nothing $ M.fromList
2013-10-01 20:08:01 +00:00
[("gitrepo", genSshUrl sshdata)]
{- 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
{- Sets up remote repository for ssh, or directory for rsync. -}
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
prepSsh needsinit sshdata a
| needsPubKey sshdata = do
2012-09-13 04:57:52 +00:00
keypair <- liftIO genSshKeyPair
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
prepSsh' needsinit sshdata sshdata' (Just keypair) a
| sshPort sshdata /= 22 = do
sshdata' <- liftIO $ setSshConfig sshdata []
prepSsh' needsinit sshdata sshdata' Nothing a
| otherwise = prepSsh' needsinit sshdata sshdata Nothing a
prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
prepSsh' needsinit origsshdata sshdata keypair a = sshSetup
[ "-p", show (sshPort origsshdata)
, genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
, remoteCommand
] Nothing (a sshdata)
2012-10-31 06:34:03 +00:00
where
remotedir = T.unpack $ sshDirectory sshdata
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
2012-10-31 06:34:03 +00:00
[ Just $ "mkdir -p " ++ shellEscape remotedir
, Just $ "cd " ++ shellEscape remotedir
, 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
, if needsPubKey origsshdata
then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair
2012-10-31 06:34:03 +00:00
else Nothing
]
rsynconly = onlyCapability origsshdata RsyncCapable
makeSshRepo :: SshData -> Handler Html
makeSshRepo sshdata
| onlyCapability sshdata RsyncCapable = setupCloudRemote TransferGroup Nothing go
| otherwise = makeSshRepoConnection go
where
go = makeSshRemote sshdata
makeSshRepoConnection :: Annex RemoteName -> Handler Html
makeSshRepoConnection a = setupRemote postsetup TransferGroup Nothing a
where
postsetup u = do
liftAssistant $ sendRemoteControl RELOAD
redirect $ EditNewRepositoryR u
makeGCryptRepo :: KeyId -> SshData -> Handler Html
makeGCryptRepo keyid sshdata = makeSshRepoConnection $
2013-10-01 20:08:01 +00:00
makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid
getAddRsyncNetR :: Handler Html
2013-03-16 22:48:23 +00:00
getAddRsyncNetR = postAddRsyncNetR
postAddRsyncNetR :: Handler Html
2013-03-16 22:48:23 +00:00
postAddRsyncNetR = do
((result, form), enctype) <- runFormPostNoToken $
renderBootstrap $ sshInputAForm hostnamefield $
SshInput Nothing Nothing Nothing 22
let showform status = inpage $
$(widgetFile "configurators/rsync.net/add")
case result of
FormSuccess sshinput
| isRsyncNet (inputHostname sshinput) ->
go sshinput
| otherwise ->
showform $ UnusableServer
"That is not a rsync.net host name."
_ -> showform UntestedServer
where
inpage = page "Add a Rsync.net repository" (Just Configuration)
2013-04-26 03:44:55 +00:00
hostnamefield = textField `withExpandableNote` ("Help", help)
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"
|]
go sshinput = do
let reponame = genSshRepoName "rsync.net"
(maybe "" T.unpack $ inputDirectory sshinput)
prepRsyncNet sshinput reponame $ \sshdata -> inpage $
checkExistingGCrypt sshdata $ do
secretkeys <- sortBy (comparing snd) . M.toList
<$> liftIO secretKeys
$(widgetFile "configurators/rsync.net/encrypt")
getMakeRsyncNetSharedR :: SshData -> Handler Html
getMakeRsyncNetSharedR = makeSshRepo . rsyncOnly
{- 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 $
sshSetup [sshhost, gitinit] Nothing $ makeGCryptRepo keyid sshdata
where
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
enableRsyncNet :: SshInput -> String -> Handler Html
enableRsyncNet sshinput reponame =
prepRsyncNet sshinput reponame $ makeSshRepo . rsyncOnly
enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html
enableRsyncNetGCrypt sshinput reponame =
prepRsyncNet sshinput reponame $ \sshdata -> whenGcryptInstalled $
checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted notinstalled $
enableGCrypt sshdata reponame
2013-09-27 05:03:50 +00:00
where
notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
notinstalled = error "internal"
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.
-}
prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
prepRsyncNet sshinput reponame a = do
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
2013-10-02 05:06:59 +00:00
keypair <- liftIO genSshKeyPair
sshdata <- liftIO $ setupSshKeyPair keypair $
(mkSshData sshinput)
{ sshRepoName = reponame
, needsPubKey = True
, sshCapabilities = [RsyncCapable]
}
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
{- I'd prefer to separate commands with && , but
2014-02-14 19:42:35 +00:00
- rsync.net's shell does not support that. -}
let remotecommand = intercalate ";"
[ "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
isRsyncNet :: Maybe Text -> Bool
isRsyncNet Nothing = False
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host